diff --git a/ghcide/src/Development/IDE/Core/Actions.hs b/ghcide/src/Development/IDE/Core/Actions.hs index 1f3db651fb..5fa3f2cbf3 100644 --- a/ghcide/src/Development/IDE/Core/Actions.hs +++ b/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 diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 18152a5421..7826b6786e 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/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) diff --git a/ghcide/src/Development/IDE/GHC/Compat/Units.hs b/ghcide/src/Development/IDE/GHC/Compat/Units.hs index 4bf7454ab5..d844a4bc62 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Units.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/Units.hs @@ -50,50 +50,54 @@ 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 @@ -101,11 +105,21 @@ 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 diff --git a/ghcide/src/Development/IDE/LSP/HoverDefinition.hs b/ghcide/src/Development/IDE/LSP/HoverDefinition.hs index 94158f7ba3..ebb739e032 100644 --- a/ghcide/src/Development/IDE/LSP/HoverDefinition.hs +++ b/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 $ diff --git a/ghcide/src/Development/IDE/Spans/AtPoint.hs b/ghcide/src/Development/IDE/Spans/AtPoint.hs index fafb18af0e..025857aeb4 100644 --- a/ghcide/src/Development/IDE/Spans/AtPoint.hs +++ b/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 diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index c690c0b9bd..4eaffca742 100644 --- a/ghcide/test/exe/Main.hs +++ b/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