Show package name and its version while hovering

ghcide/src/Development/IDE/Core/Actions.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE TypeFamilies #-}
 module Development.IDE.Core.Actions
 ( getAtPoint
+, getAtPointPackage
 , getDefinition
 , getTypeDefinition
 , highlightAtPoint
@@ -66,6 +67,15 @@ getAtPoint file pos = runMaybeT $ do
   !pos' <- MaybeT (return $ fromCurrentPosition mapping pos)
   MaybeT $ pure $ first (toCurrentRange mapping =<<) <$> AtPoint.atPoint opts hf dkMap env pos'
 
+-- | Try to get hover text for the package it belongs to under point.
+getAtPointPackage :: NormalizedFilePath -> Position -> IdeAction (Maybe (Maybe Range, [T.Text]))
+getAtPointPackage file pos = runMaybeT $ do
+  (hf, mapping) <- useE GetHieAst file
+  env <- hscEnv . fst <$> useE GhcSession file
+
+  !pos' <- MaybeT (return $ fromCurrentPosition mapping pos)
+  MaybeT $ liftIO $ fmap (first (toCurrentRange mapping =<<)) <$> AtPoint.atPointPackage hf env pos'
+
 toCurrentLocations :: PositionMapping -> [Location] -> [Location]
 toCurrentLocations mapping = mapMaybe go
   where

ghcide/src/Development/IDE/Core/Shake.hs

@@ -6,6 +6,7 @@
 {-# LANGUAGE DerivingStrategies        #-}
 {-# LANGUAGE DuplicateRecordFields     #-}
 {-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE FlexibleInstances         #-}
 {-# LANGUAGE PackageImports            #-}
 {-# LANGUAGE PolyKinds                 #-}
 {-# LANGUAGE RankNTypes                #-}
@@ -984,6 +985,17 @@ usesWithStale_ key files = do
 newtype IdeAction a = IdeAction { runIdeActionT  :: (ReaderT ShakeExtras IO) a }
     deriving newtype (MonadReader ShakeExtras, MonadIO, Functor, Applicative, Monad, Semigroup)
 
+-- Only for combining module name and its package name while hovering over import statements
+instance {-# OVERLAPPING #-} Semigroup (IdeAction (Maybe (Maybe Range, [T.Text]))) where
+    IdeAction a <> IdeAction b = IdeAction $ do
+        val <- b
+        fmap (flip merge val) a
+        where
+            merge Nothing b = b
+            merge (Just (ra, [ta])) (Just (rb, [tb])) =
+                if ra == rb then Just (ra, [ta <> tb]) else Just (ra, [ta])
+            merge a _ = a
+
 -- https://hub.darcs.net/ross/transformers/issue/86
 deriving instance (Semigroup (m a)) => Semigroup (ReaderT r m a)
 

ghcide/src/Development/IDE/GHC/Compat/Units.hs

@@ -50,62 +50,76 @@ module Development.IDE.GHC.Compat.Units (
     filterInplaceUnits,
     FinderCache,
     showSDocForUser',
+    findImportedModule
     ) where
 
 import           Control.Monad
-import qualified Data.List.NonEmpty              as NE
-import qualified Data.Map.Strict                 as Map
+import qualified Data.List.NonEmpty                    as NE
+import qualified Data.Map.Strict                       as Map
 #if MIN_VERSION_ghc(9,3,0)
 import           GHC.Unit.Home.ModInfo
 #endif
 #if MIN_VERSION_ghc(9,0,0)
 #if MIN_VERSION_ghc(9,2,0)
-import qualified GHC.Data.ShortText              as ST
+import qualified GHC.Data.ShortText                    as ST
 #if !MIN_VERSION_ghc(9,3,0)
-import           GHC.Driver.Env                  (hsc_unit_dbs)
+import           GHC.Driver.Env                        (hsc_unit_dbs)
 #endif
 import           GHC.Driver.Ppr
 import           GHC.Unit.Env
 import           GHC.Unit.External
-import           GHC.Unit.Finder
+import           GHC.Unit.Finder                       hiding
+                                                       (findImportedModule)
 #else
 import           GHC.Driver.Types
 #endif
 import           GHC.Data.FastString
-import qualified GHC.Driver.Session              as DynFlags
+import qualified GHC.Driver.Session                    as DynFlags
 import           GHC.Types.Unique.Set
-import qualified GHC.Unit.Info                   as UnitInfo
-import           GHC.Unit.State                  (LookupResult, UnitInfo,
-                                                  UnitState (unitInfoMap))
-import qualified GHC.Unit.State                  as State
-import           GHC.Unit.Types                  hiding (moduleUnit, toUnitId)
-import qualified GHC.Unit.Types                  as Unit
+import qualified GHC.Unit.Info                         as UnitInfo
+import           GHC.Unit.State                        (LookupResult, UnitInfo,
+                                                        UnitState (unitInfoMap))
+import qualified GHC.Unit.State                        as State
+import           GHC.Unit.Types                        hiding (moduleUnit,
+                                                        toUnitId)
+import qualified GHC.Unit.Types                        as Unit
 import           GHC.Utils.Outputable
 #else
 import qualified DynFlags
 import           FastString
-import           GhcPlugins                      (SDoc, showSDocForUser)
+import           GhcPlugins                            (SDoc, showSDocForUser)
 import           HscTypes
-import           Module                          hiding (moduleUnitId)
+import           Module                                hiding (moduleUnitId)
 import qualified Module
-import           Packages                        (InstalledPackageInfo (haddockInterfaces, packageName),
-                                                  LookupResult, PackageConfig,
-                                                  PackageConfigMap,
-                                                  PackageState,
-                                                  getPackageConfigMap,
-                                                  lookupPackage')
+import           Packages                              (InstalledPackageInfo (haddockInterfaces, packageName),
+                                                        LookupResult,
+                                                        PackageConfig,
+                                                        PackageConfigMap,
+                                                        PackageState,
+                                                        getPackageConfigMap,
+                                                        lookupPackage')
 import qualified Packages
 #endif
 
 import           Development.IDE.GHC.Compat.Core
 import           Development.IDE.GHC.Compat.Env
 import           Development.IDE.GHC.Compat.Outputable
 #if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,2,0)
-import           Data.Map                        (Map)
+import           Data.Map                              (Map)
 #endif
 import           Data.Either
 import           Data.Version
 import qualified GHC
+#if MIN_VERSION_ghc(9,3,0)
+import           GHC.Types.PkgQual                     (PkgQual (NoPkgQual))
+#endif
+#if MIN_VERSION_ghc(9,1,0)
+import qualified GHC.Unit.Finder                       as GHC
+#elif MIN_VERSION_ghc(9,0,0)
+import qualified GHC.Driver.Finder                     as GHC
+#else
+import qualified Finder                                as GHC
+#endif
 
 #if MIN_VERSION_ghc(9,0,0)
 type PreloadUnitClosure = UniqSet UnitId
@@ -407,3 +421,14 @@ showSDocForUser' env = showSDocForUser (hsc_dflags env) (unitState env)
 #else
 showSDocForUser' env = showSDocForUser (hsc_dflags env)
 #endif
+
+findImportedModule :: HscEnv -> ModuleName -> IO (Maybe Module)
+findImportedModule env mn = do
+#if MIN_VERSION_ghc(9,3,0)
+    res <- GHC.findImportedModule env mn NoPkgQual
+#else
+    res <- GHC.findImportedModule env mn Nothing
+#endif
+    case res of
+        Found _ mod -> pure . pure $ mod
+        _           -> pure Nothing

ghcide/src/Development/IDE/LSP/HoverDefinition.hs

@@ -26,14 +26,14 @@ import           Language.LSP.Types
 
 import qualified Data.Text                      as T
 
-gotoDefinition :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either ResponseError (ResponseResult TextDocumentDefinition))
-hover          :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either ResponseError (Maybe Hover))
+gotoDefinition     :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either ResponseError (ResponseResult TextDocumentDefinition))
+hover              :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either ResponseError (Maybe Hover))
 gotoTypeDefinition :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either ResponseError (ResponseResult TextDocumentTypeDefinition))
-documentHighlight :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either ResponseError (List DocumentHighlight))
-gotoDefinition = request "Definition" getDefinition (InR $ InL $ List []) (InR . InL . List)
-gotoTypeDefinition = request "TypeDefinition" getTypeDefinition (InR $ InL $ List []) (InR . InL . List)
-hover          = request "Hover"      getAtPoint     Nothing      foundHover
-documentHighlight = request "DocumentHighlight" highlightAtPoint (List []) List
+documentHighlight  :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either ResponseError (List DocumentHighlight))
+gotoDefinition     = request "Definition"        getDefinition (InR $ InL $ List []) (InR . InL . List)
+gotoTypeDefinition = request "TypeDefinition"    getTypeDefinition (InR $ InL $ List []) (InR . InL . List)
+hover              = request "Hover"             (getAtPoint <> getAtPointPackage) Nothing foundHover
+documentHighlight  = request "DocumentHighlight" highlightAtPoint (List []) List
 
 references :: IdeState -> ReferenceParams -> LSP.LspM c (Either ResponseError (List Location))
 references ide (ReferenceParams (TextDocumentIdentifier uri) pos _ _ _) = liftIO $

ghcide/src/Development/IDE/Spans/AtPoint.hs

@@ -9,6 +9,7 @@
 -- These are all pure functions that should execute quickly.
 module Development.IDE.Spans.AtPoint (
     atPoint
+  , atPointPackage
   , gotoDefinition
   , gotoTypeDefinition
   , documentHighlight
@@ -51,7 +52,7 @@ import qualified Data.Text                            as T
 
 import qualified Data.Array                           as A
 import           Data.Either
-import           Data.List                            (isSuffixOf)
+import           Data.List                            (isSuffixOf, uncons)
 import           Data.List.Extra                      (dropEnd1, nubOrd)
 
 import           Data.Version                         (showVersion)
@@ -205,6 +206,44 @@ gotoDefinition
 gotoDefinition withHieDb getHieFile ideOpts imports srcSpans pos
   = lift $ locationsAtPoint withHieDb getHieFile ideOpts imports pos srcSpans
 
+-- | Synopsis for the package at a given position.
+atPointPackage :: HieAstResult
+  -> HscEnv
+  -> Position
+  -> IO (Maybe (Maybe Range, [T.Text]))
+atPointPackage (HAR _ hf _ _ kind) env pos =
+  case uncons (pointCommand hf pos hoverInfo) of
+    Nothing     -> pure Nothing
+    Just (a, _) -> a
+  where
+    hoverInfo ast = runMaybeT $ do
+      (range, mn) <- getModuleName ast
+      pkg <- MaybeT $ findImportedModule env mn
+      txt <- MaybeT $ pure $ packageNameWithVersion pkg env
+      pure (range, pure $ "\n\n" <> txt)
+
+    getModuleName ast = MaybeT . pure $ do
+      (n, _) <- listToMaybe names
+      m <- leftToMaybe n
+      pure (Just range, m)
+      where
+        range = realSrcSpanToRange $ nodeSpan ast
+        info = nodeInfoH kind ast
+        names = M.assocs $ nodeIdentifiers info
+
+    leftToMaybe (Left l)  = Just l
+    leftToMaybe (Right _) = Nothing
+
+-- | Return the package name and version of a module.
+-- For example, given module `Data.List`, it should return something like `base-4.x`.
+packageNameWithVersion :: Module -> HscEnv -> Maybe T.Text
+packageNameWithVersion m env = do
+  let pid = moduleUnit m
+  conf <- lookupUnit env pid
+  let pkgName = T.pack $ unitPackageNameString conf
+      version = T.pack $ showVersion (unitPackageVersion conf)
+  pure $ pkgName <> "-" <> version
+
 -- | Synopsis for the name at a given position.
 atPoint
   :: IdeOptions
@@ -254,11 +293,8 @@ atPoint IdeOptions{} (HAR _ hf _ _ kind) (DKMap dm km) env pos = listToMaybe $ p
 
         prettyPackageName n = do
           m <- nameModule_maybe n
-          let pid = moduleUnit m
-          conf <- lookupUnit env pid
-          let pkgName = T.pack $ unitPackageNameString conf
-              version = T.pack $ showVersion (unitPackageVersion conf)
-          pure $ "*(" <> pkgName <> "-" <> version <> ")*"
+          pkgTxt <- packageNameWithVersion m env
+          pure $ "*(" <> pkgTxt <> ")*"
 
         prettyTypes = map (("_ :: "<>) . prettyType) types
         prettyType t = case kind of

ghcide/test/exe/Main.hs

@@ -1155,6 +1155,7 @@ findDefinitionAndHoverTests = let
   reexported = Position 55 14 ; reexportedSig = getDocUri "Bar.hs" >>= \bar -> return [ExpectHoverText ["Bar", "Bar", "Haddock"], mkL bar 3 (if ghcVersion >= GHC94 then 5 else 0) 3 (if ghcVersion >= GHC94 then 8 else 14)]
   thLocL57 = Position 59 10 ; thLoc = [ExpectHoverText ["Identity"]]
   cmtL68 = Position 67  0  ;  lackOfdEq = [ExpectHoverExcludeText ["$dEq"]]
+  import310 = Position 3 10; pkgTxt = [ExpectHoverText ["Data.Text\n\ntext-"]]
   in
   mkFindTests
   --      def    hover  look       expect
@@ -1218,6 +1219,7 @@ findDefinitionAndHoverTests = let
         test  no     broken    thLocL57   thLoc         "TH Splice Hover"
        | otherwise ->
         test  no     yes       thLocL57   thLoc         "TH Splice Hover"
+  , test  yes    yes    import310  pkgTxt         "show package name and its version"
   ]
   where yes, broken :: (TestTree -> Maybe TestTree)
         yes    = Just -- test should run and pass