From 5924bb99138c1c7f9967c0f369157cbc1cbb03b3 Mon Sep 17 00:00:00 2001 From: Dobromir Nikolov Date: Wed, 13 Aug 2025 19:32:54 +0300 Subject: [PATCH 1/3] Add "Go to type" hyperlinks in the hover popup. --- ghcide/ghcide.cabal | 1 + ghcide/src/Development/IDE/Core/Actions.hs | 21 +-- ghcide/src/Development/IDE/Core/LookupMod.hs | 24 ++++ ghcide/src/Development/IDE/Core/Shake.hs | 3 +- ghcide/src/Development/IDE/Spans/AtPoint.hs | 142 +++++++++++++++---- 5 files changed, 146 insertions(+), 45 deletions(-) create mode 100644 ghcide/src/Development/IDE/Core/LookupMod.hs diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 6c2faa59a2..963ea99ae6 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -131,6 +131,7 @@ library Development.IDE.Core.FileStore Development.IDE.Core.FileUtils Development.IDE.Core.IdeConfiguration + Development.IDE.Core.LookupMod Development.IDE.Core.OfInterest Development.IDE.Core.PluginUtils Development.IDE.Core.PositionMapping diff --git a/ghcide/src/Development/IDE/Core/Actions.hs b/ghcide/src/Development/IDE/Core/Actions.hs index 61614cb0ca..ab72aa21dd 100644 --- a/ghcide/src/Development/IDE/Core/Actions.hs +++ b/ghcide/src/Development/IDE/Core/Actions.hs @@ -17,13 +17,13 @@ import qualified Data.HashMap.Strict as HM import Data.Maybe import qualified Data.Text as T import Data.Tuple.Extra +import Development.IDE.Core.LookupMod (lookupMod) import Development.IDE.Core.OfInterest import Development.IDE.Core.PluginUtils import Development.IDE.Core.PositionMapping import Development.IDE.Core.RuleTypes import Development.IDE.Core.Service import Development.IDE.Core.Shake -import Development.IDE.GHC.Compat hiding (writeHieFile) import Development.IDE.Graph import qualified Development.IDE.Spans.AtPoint as AtPoint import Development.IDE.Types.HscEnvEq (hscEnv) @@ -35,19 +35,6 @@ import Language.LSP.Protocol.Types (DocumentHighlight (..), normalizedFilePathToUri, uriToNormalizedFilePath) - --- | Eventually this will lookup/generate URIs for files in dependencies, but not in the --- project. Right now, this is just a stub. -lookupMod - :: HieDbWriter -- ^ access the database - -> FilePath -- ^ The `.hie` file we got from the database - -> ModuleName - -> Unit - -> Bool -- ^ Is this file a boot file? - -> MaybeT IdeAction Uri -lookupMod _dbchan _hie_f _mod _uid _boot = MaybeT $ pure Nothing - - -- IMPORTANT NOTE : make sure all rules `useWithStaleFastMT`d by these have a "Persistent Stale" rule defined, -- so we can quickly answer as soon as the IDE is opened -- Even if we don't have persistent information on disk for these rules, the persistent rule @@ -62,11 +49,15 @@ getAtPoint file pos = runMaybeT $ do opts <- liftIO $ getIdeOptionsIO ide (hf, mapping) <- useWithStaleFastMT GetHieAst file + shakeExtras <- lift askShake + env <- hscEnv . fst <$> useWithStaleFastMT GhcSession file dkMap <- lift $ maybe (DKMap mempty mempty) fst <$> runMaybeT (useWithStaleFastMT GetDocMap file) !pos' <- MaybeT (return $ fromCurrentPosition mapping pos) - MaybeT $ liftIO $ fmap (first (toCurrentRange mapping =<<)) <$> AtPoint.atPoint opts hf dkMap env pos' + + MaybeT $ liftIO $ fmap (first (toCurrentRange mapping =<<)) <$> + AtPoint.atPoint opts shakeExtras hf dkMap env pos' -- | Converts locations in the source code to their current positions, -- taking into account changes that may have occurred due to edits. diff --git a/ghcide/src/Development/IDE/Core/LookupMod.hs b/ghcide/src/Development/IDE/Core/LookupMod.hs new file mode 100644 index 0000000000..981773c34b --- /dev/null +++ b/ghcide/src/Development/IDE/Core/LookupMod.hs @@ -0,0 +1,24 @@ +module Development.IDE.Core.LookupMod (lookupMod, LookupModule) where + +import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) +import Development.IDE.Core.Shake (HieDbWriter, IdeAction) +import Development.IDE.GHC.Compat.Core (ModuleName, Unit) +import Development.IDE.Types.Location (Uri) + +-- | Gives a Uri for the module, given the .hie file location and the the module info +-- The Bool denotes if it is a boot module +type LookupModule m = FilePath -> ModuleName -> Unit -> Bool -> MaybeT m Uri + +-- | Eventually this will lookup/generate URIs for files in dependencies, but not in the +-- project. Right now, this is just a stub. +lookupMod :: + -- | access the database + HieDbWriter -> + -- | The `.hie` file we got from the database + FilePath -> + ModuleName -> + Unit -> + -- | Is this file a boot file? + Bool -> + MaybeT IdeAction Uri +lookupMod _dbchan _hie_f _mod _uid _boot = MaybeT $ pure Nothing diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 6fc9a4d00e..2fbaa892fa 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -76,7 +76,8 @@ module Development.IDE.Core.Shake( Log(..), VFSModified(..), getClientConfigAction, ThreadQueue(..), - runWithSignal + runWithSignal, + askShake ) where import Control.Concurrent.Async diff --git a/ghcide/src/Development/IDE/Spans/AtPoint.hs b/ghcide/src/Development/IDE/Spans/AtPoint.hs index 50df0f5ba5..d6cf68648e 100644 --- a/ghcide/src/Development/IDE/Spans/AtPoint.hs +++ b/ghcide/src/Development/IDE/Spans/AtPoint.hs @@ -45,7 +45,6 @@ import Development.IDE.GHC.Util (printOutputable) import Development.IDE.Spans.Common import Development.IDE.Types.Options -import Control.Applicative import Control.Monad.Extra import Control.Monad.IO.Class import Control.Monad.Trans.Class @@ -61,17 +60,25 @@ import Data.Either import Data.List.Extra (dropEnd1, nubOrd) +import Control.Lens ((^.)) import Data.Either.Extra (eitherToMaybe) import Data.List (isSuffixOf, sortOn) +import Data.Set (Set) +import qualified Data.Set as S import Data.Tree import qualified Data.Tree as T import Data.Version (showVersion) +import Development.IDE.Core.LookupMod (LookupModule, lookupMod) +import Development.IDE.Core.Shake (ShakeExtras (..), + runIdeAction) import Development.IDE.Types.Shake (WithHieDb) import GHC.Iface.Ext.Types (EvVarSource (..), HieAST (..), HieASTs (..), HieArgs (..), - HieType (..), Identifier, + HieType (..), + HieTypeFix (..), + Identifier, IdentifierDetails (..), NodeInfo (..), Scope, Span) @@ -86,12 +93,9 @@ import GHC.Iface.Ext.Utils (EvidenceInfo (..), selectSmallestContaining) import HieDb hiding (pointCommand, withHieDb) +import qualified Language.LSP.Protocol.Lens as L import System.Directory (doesFileExist) --- | Gives a Uri for the module, given the .hie file location and the the module info --- The Bool denotes if it is a boot module -type LookupModule m = FilePath -> ModuleName -> Unit -> Bool -> MaybeT m Uri - -- | HieFileResult for files of interest, along with the position mappings newtype FOIReferences = FOIReferences (HM.HashMap NormalizedFilePath (HieAstResult, PositionMapping)) @@ -251,31 +255,41 @@ gotoImplementation withHieDb getHieFile ideOpts srcSpans pos -- | Synopsis for the name at a given position. atPoint :: IdeOptions + -> ShakeExtras -> HieAstResult -> DocAndTyThingMap -> HscEnv -> Position -> IO (Maybe (Maybe Range, [T.Text])) -atPoint IdeOptions{} (HAR _ (hf :: HieASTs a) rf _ (kind :: HieKind hietype)) (DKMap dm km) env pos = +atPoint opts@IdeOptions{} shakeExtras@ShakeExtras{ withHieDb, hiedbWriter } har@(HAR _ (hf :: HieASTs a) rf _ (kind :: HieKind hietype)) (DKMap dm km) env pos = listToMaybe <$> sequence (pointCommand hf pos hoverInfo) where -- Hover info for values/data hoverInfo :: HieAST hietype -> IO (Maybe Range, [T.Text]) hoverInfo ast = do - prettyNames <- mapM prettyName names - pure (Just range, prettyNames ++ pTypes) + locationsWithIdentifier <- runIdeAction "TypeCheck" shakeExtras $ do + runMaybeT $ gotoTypeDefinition withHieDb (lookupMod hiedbWriter) opts har pos + + let locationsMap = M.fromList $ mapMaybe (\(loc, identifier) -> case identifier of + Right typeName -> + -- Filter out type variables (polymorphic names like 'a', 'b', etc.) + if isTyVarName typeName + then Nothing + else Just (typeName, loc) + Left _moduleName -> Nothing) $ fromMaybe [] locationsWithIdentifier + + prettyNames <- mapM (prettyName locationsMap) names + pure (Just range, prettyNames ++ pTypes locationsMap) where - pTypes :: [T.Text] - pTypes - | Prelude.length names == 1 = dropEnd1 $ map wrapHaskell prettyTypes - | otherwise = map wrapHaskell prettyTypes + pTypes :: M.Map Name Location -> [T.Text] + pTypes locationsMap = + case names of + [_singleName] -> dropEnd1 $ prettyTypes Nothing locationsMap + _ -> prettyTypes Nothing locationsMap range :: Range range = realSrcSpanToRange $ nodeSpan ast - wrapHaskell :: T.Text -> T.Text - wrapHaskell x = "\n```haskell\n"<>x<>"\n```\n" - info :: NodeInfo hietype info = nodeInfoH kind ast @@ -284,8 +298,8 @@ atPoint IdeOptions{} (HAR _ (hf :: HieASTs a) rf _ (kind :: HieKind hietype)) (D names :: [(Identifier, IdentifierDetails hietype)] names = sortOn (any isEvidenceUse . identInfo . snd) $ M.assocs $ nodeIdentifiers info - prettyName :: (Either ModuleName Name, IdentifierDetails hietype) -> IO T.Text - prettyName (Right n, dets) + prettyName :: M.Map Name Location -> (Either ModuleName Name, IdentifierDetails hietype) -> IO T.Text + prettyName locationsMap (Right n, dets) -- We want to print evidence variable using a readable tree structure. -- Evidence variables contain information why a particular instance or -- type equality was chosen, paired with location information. @@ -299,20 +313,23 @@ atPoint IdeOptions{} (HAR _ (hf :: HieASTs a) rf _ (kind :: HieKind hietype)) (D pure $ evidenceTree <> "\n" -- Identifier details that are not evidence variables are used to display type information and -- documentation of that name. - | otherwise = + | otherwise = do let - typeSig = wrapHaskell (printOutputable n <> maybe "" (" :: " <>) ((prettyType <$> identType dets) <|> maybeKind)) + typeSig = case identType dets of + Just t -> prettyType (Just n) locationsMap t + Nothing -> case safeTyThingType =<< lookupNameEnv km n of + Just kind -> prettyTypeFromType (Just n) locationsMap kind + Nothing -> wrapHaskell (printOutputable n) definitionLoc = maybeToList (pretty (definedAt n) (prettyPackageName n)) docs = maybeToList (T.unlines . spanDocToMarkdown <$> lookupNameEnv dm n) - in - pure $ T.unlines $ - [typeSig] ++ definitionLoc ++ docs - where maybeKind = fmap printOutputable $ safeTyThingType =<< lookupNameEnv km n + + pure $ T.unlines $ [typeSig] ++ definitionLoc ++ docs + where pretty Nothing Nothing = Nothing pretty (Just define) Nothing = Just $ define <> "\n" pretty Nothing (Just pkgName) = Just $ pkgName <> "\n" pretty (Just define) (Just pkgName) = Just $ define <> " " <> pkgName <> "\n" - prettyName (Left m,_) = packageNameForImportStatement m + prettyName _locationsMap (Left m,_) = packageNameForImportStatement m prettyPackageName :: Name -> Maybe T.Text prettyPackageName n = do @@ -345,11 +362,63 @@ atPoint IdeOptions{} (HAR _ (hf :: HieASTs a) rf _ (kind :: HieKind hietype)) (D types :: [hietype] types = nodeType info - prettyTypes :: [T.Text] - prettyTypes = map (("_ :: "<>) . prettyType) types + prettyTypes :: Maybe Name -> M.Map Name Location -> [T.Text] + prettyTypes boundNameMay locationsMap = + map (prettyType boundNameMay locationsMap) types + + prettyTypeFromType :: Maybe Name -> M.Map Name Location -> Type -> T.Text + prettyTypeFromType boundNameMay locationsMap ty = + prettyTypeCommon boundNameMay locationsMap (S.fromList $ namesInType ty) (printOutputable ty) + + prettyType :: Maybe Name -> M.Map Name Location -> hietype -> T.Text + prettyType boundNameMay locationsMap t = + prettyTypeCommon boundNameMay locationsMap (typeNames t) (printOutputable . expandType $ t) + + prettyTypeCommon :: Maybe Name -> M.Map Name Location -> Set Name -> T.Text -> T.Text + prettyTypeCommon boundNameMay locationsMap names expandedType = + let nameToUse = case boundNameMay of + Just n -> printOutputable n + Nothing -> "_" + expandedWithName = nameToUse <> " :: " <> expandedType + codeBlock = wrapHaskell expandedWithName + links = case boundNameMay of + Just _ -> generateLinksList locationsMap names + -- This is so we don't get flooded with links, e.g: + -- foo :: forall a. MyType a -> a + -- Go to MyType + -- _ :: forall a. MyType a -> a + -- Go to MyType -- <- we don't want this as it's already present + Nothing -> "" + in codeBlock <> links + + generateLinksList :: M.Map Name Location -> Set Name -> T.Text + generateLinksList locationsMap (S.toList -> names) = + if null generated + then "" + else "\n" <> "Go to " <> T.intercalate " | " generated <> "\n" + where + generated = mapMaybe generateLink names - prettyType :: hietype -> T.Text - prettyType = printOutputable . expandType + generateLink name = do + case M.lookup name locationsMap of + Just (Location uri range) -> + let nameText = printOutputable name + link = "[" <> nameText <> "](" <> getUriText uri <> "#L" <> + T.pack (show (range ^. L.start . L.line + 1)) <> ")" + in Just link + Nothing -> Nothing + + wrapHaskell :: T.Text -> T.Text + wrapHaskell x = "\n```haskell\n"<>x<>"\n```\n" + + getUriText :: Uri -> T.Text + getUriText (Uri t) = t + + typeNames :: a -> Set Name + typeNames t = S.fromList $ case kind of + HieFresh -> namesInType t + HieFromDisk full_file -> do + namesInHieTypeFix $ recoverFullType t (hie_types full_file) expandType :: a -> SDoc expandType t = case kind of @@ -468,9 +537,24 @@ namesInType (CastTy t _) = namesInType t namesInType (LitTy _) = [] namesInType _ = [] + getTypes :: [Type] -> [Name] getTypes = concatMap namesInType +namesInHieTypeFix :: HieTypeFix -> [Name] +namesInHieTypeFix (Roll hieType) = namesInHieType hieType + +namesInHieType :: HieType HieTypeFix -> [Name] +namesInHieType (HTyVarTy n) = [n] +namesInHieType (HAppTy a (HieArgs args)) = namesInHieTypeFix a ++ concatMap (namesInHieTypeFix . snd) args +namesInHieType (HTyConApp tc (HieArgs args)) = ifaceTyConName tc : concatMap (namesInHieTypeFix . snd) args +namesInHieType (HForAllTy ((binder, constraint), _) body) = binder : namesInHieTypeFix constraint ++ namesInHieTypeFix body +namesInHieType (HFunTy mult arg res) = namesInHieTypeFix mult ++ namesInHieTypeFix arg ++ namesInHieTypeFix res +namesInHieType (HQualTy constraint body) = namesInHieTypeFix constraint ++ namesInHieTypeFix body +namesInHieType (HLitTy _) = [] +namesInHieType (HCastTy a) = namesInHieTypeFix a +namesInHieType HCoercionTy = [] + -- | Find 'Location's of definition at a specific point and return them along with their 'Identifier's. locationsAtPoint :: forall m From 723d56ccd5a072fdfef6ec01b7365747e158db85 Mon Sep 17 00:00:00 2001 From: Dobromir Nikolov Date: Mon, 18 Aug 2025 09:44:13 +0300 Subject: [PATCH 2/3] Get rid of redundant dropEnd1 --- ghcide/src/Development/IDE/Spans/AtPoint.hs | 11 +++-------- 1 file changed, 3 insertions(+), 8 deletions(-) diff --git a/ghcide/src/Development/IDE/Spans/AtPoint.hs b/ghcide/src/Development/IDE/Spans/AtPoint.hs index d6cf68648e..ec955ecdee 100644 --- a/ghcide/src/Development/IDE/Spans/AtPoint.hs +++ b/ghcide/src/Development/IDE/Spans/AtPoint.hs @@ -57,7 +57,7 @@ import qualified Data.Text as T import qualified Data.Array as A import Data.Either -import Data.List.Extra (dropEnd1, nubOrd) +import Data.List.Extra (nubOrd) import Control.Lens ((^.)) @@ -279,14 +279,9 @@ atPoint opts@IdeOptions{} shakeExtras@ShakeExtras{ withHieDb, hiedbWriter } har@ Left _moduleName -> Nothing) $ fromMaybe [] locationsWithIdentifier prettyNames <- mapM (prettyName locationsMap) names - pure (Just range, prettyNames ++ pTypes locationsMap) - where - pTypes :: M.Map Name Location -> [T.Text] - pTypes locationsMap = - case names of - [_singleName] -> dropEnd1 $ prettyTypes Nothing locationsMap - _ -> prettyTypes Nothing locationsMap + pure (Just range, prettyNames ++ prettyTypes Nothing locationsMap) + where range :: Range range = realSrcSpanToRange $ nodeSpan ast From b1eab33f82f0c8122b457e89b7efdee4b3f6fd82 Mon Sep 17 00:00:00 2001 From: Dobromir Nikolov Date: Mon, 18 Aug 2025 09:45:32 +0300 Subject: [PATCH 3/3] Actually realize that the dropEnd1 is old code and revert "Get rid of redundant dropEnd1" This reverts commit 723d56ccd5a072fdfef6ec01b7365747e158db85. --- ghcide/src/Development/IDE/Spans/AtPoint.hs | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/ghcide/src/Development/IDE/Spans/AtPoint.hs b/ghcide/src/Development/IDE/Spans/AtPoint.hs index ec955ecdee..d6cf68648e 100644 --- a/ghcide/src/Development/IDE/Spans/AtPoint.hs +++ b/ghcide/src/Development/IDE/Spans/AtPoint.hs @@ -57,7 +57,7 @@ import qualified Data.Text as T import qualified Data.Array as A import Data.Either -import Data.List.Extra (nubOrd) +import Data.List.Extra (dropEnd1, nubOrd) import Control.Lens ((^.)) @@ -279,9 +279,14 @@ atPoint opts@IdeOptions{} shakeExtras@ShakeExtras{ withHieDb, hiedbWriter } har@ Left _moduleName -> Nothing) $ fromMaybe [] locationsWithIdentifier prettyNames <- mapM (prettyName locationsMap) names - - pure (Just range, prettyNames ++ prettyTypes Nothing locationsMap) + pure (Just range, prettyNames ++ pTypes locationsMap) where + pTypes :: M.Map Name Location -> [T.Text] + pTypes locationsMap = + case names of + [_singleName] -> dropEnd1 $ prettyTypes Nothing locationsMap + _ -> prettyTypes Nothing locationsMap + range :: Range range = realSrcSpanToRange $ nodeSpan ast