Skip to content

Commit 72f866f

Browse files
dnikolovvdnikolovv
committed
Add "Go to type" hyperlinks in the hover popup.
1 parent 9b952c8 commit 72f866f

File tree

5 files changed

+146
-45
lines changed

5 files changed

+146
-45
lines changed

‎ghcide/ghcide.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -131,6 +131,7 @@ library
131131
Development.IDE.Core.FileStore
132132
Development.IDE.Core.FileUtils
133133
Development.IDE.Core.IdeConfiguration
134+
Development.IDE.Core.LookupMod
134135
Development.IDE.Core.OfInterest
135136
Development.IDE.Core.PluginUtils
136137
Development.IDE.Core.PositionMapping

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

Lines changed: 6 additions & 15 deletions
Original file line numberDiff line numberDiff line change
@@ -17,13 +17,13 @@ import qualified Data.HashMap.Strict as HM
1717
import Data.Maybe
1818
import qualified Data.Text as T
1919
import Data.Tuple.Extra
20+
import Development.IDE.Core.LookupMod (lookupMod)
2021
import Development.IDE.Core.OfInterest
2122
import Development.IDE.Core.PluginUtils
2223
import Development.IDE.Core.PositionMapping
2324
import Development.IDE.Core.RuleTypes
2425
import Development.IDE.Core.Service
2526
import Development.IDE.Core.Shake
26-
import Development.IDE.GHC.Compat hiding (writeHieFile)
2727
import Development.IDE.Graph
2828
import qualified Development.IDE.Spans.AtPoint as AtPoint
2929
import Development.IDE.Types.HscEnvEq (hscEnv)
@@ -35,19 +35,6 @@ import Language.LSP.Protocol.Types (DocumentHighlight (..),
3535
normalizedFilePathToUri,
3636
uriToNormalizedFilePath)
3737

38-
39-
-- | Eventually this will lookup/generate URIs for files in dependencies, but not in the
40-
-- project. Right now, this is just a stub.
41-
lookupMod
42-
:: HieDbWriter -- ^ access the database
43-
-> FilePath -- ^ The `.hie` file we got from the database
44-
-> ModuleName
45-
-> Unit
46-
-> Bool -- ^ Is this file a boot file?
47-
-> MaybeT IdeAction Uri
48-
lookupMod _dbchan _hie_f _mod _uid _boot = MaybeT $ pure Nothing
49-
50-
5138
-- IMPORTANT NOTE : make sure all rules `useWithStaleFastMT`d by these have a "Persistent Stale" rule defined,
5239
-- so we can quickly answer as soon as the IDE is opened
5340
-- 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
6249
opts <- liftIO $ getIdeOptionsIO ide
6350

6451
(hf, mapping) <- useWithStaleFastMT GetHieAst file
52+
shakeExtras <- lift askShake
53+
6554
env <- hscEnv . fst <$> useWithStaleFastMT GhcSession file
6655
dkMap <- lift $ maybe (DKMap mempty mempty mempty) fst <$> runMaybeT (useWithStaleFastMT GetDocMap file)
6756

6857
!pos' <- MaybeT (return $ fromCurrentPosition mapping pos)
69-
MaybeT $ liftIO $ fmap (first (toCurrentRange mapping =<<)) <$> AtPoint.atPoint opts hf dkMap env pos'
58+
59+
MaybeT $ liftIO $ fmap (first (toCurrentRange mapping =<<)) <$>
60+
AtPoint.atPoint opts shakeExtras hf dkMap env pos'
7061

7162
-- | Converts locations in the source code to their current positions,
7263
-- taking into account changes that may have occurred due to edits.

‎ghcide/src/Development/IDE/Core/LookupMod.hs‎

Lines changed: 24 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,24 @@
1+
module Development.IDE.Core.LookupMod (lookupMod, LookupModule) where
2+
3+
import Control.Monad.Trans.Maybe (MaybeT (MaybeT))
4+
import Development.IDE.Core.Shake (HieDbWriter, IdeAction)
5+
import Development.IDE.GHC.Compat.Core (ModuleName, Unit)
6+
import Development.IDE.Types.Location (Uri)
7+
8+
-- | Gives a Uri for the module, given the .hie file location and the the module info
9+
-- The Bool denotes if it is a boot module
10+
type LookupModule m = FilePath -> ModuleName -> Unit -> Bool -> MaybeT m Uri
11+
12+
-- | Eventually this will lookup/generate URIs for files in dependencies, but not in the
13+
-- project. Right now, this is just a stub.
14+
lookupMod ::
15+
-- | access the database
16+
HieDbWriter ->
17+
-- | The `.hie` file we got from the database
18+
FilePath ->
19+
ModuleName ->
20+
Unit ->
21+
-- | Is this file a boot file?
22+
Bool ->
23+
MaybeT IdeAction Uri
24+
lookupMod _dbchan _hie_f _mod _uid _boot = MaybeT $ pure Nothing

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

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -76,7 +76,8 @@ module Development.IDE.Core.Shake(
7676
Log(..),
7777
VFSModified(..), getClientConfigAction,
7878
ThreadQueue(..),
79-
runWithSignal
79+
runWithSignal,
80+
askShake
8081
) where
8182

8283
import Control.Concurrent.Async

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

Lines changed: 113 additions & 29 deletions
Original file line numberDiff line numberDiff line change
@@ -45,7 +45,6 @@ import Development.IDE.GHC.Util (printOutputable)
4545
import Development.IDE.Spans.Common
4646
import Development.IDE.Types.Options
4747

48-
import Control.Applicative
4948
import Control.Monad.Extra
5049
import Control.Monad.IO.Class
5150
import Control.Monad.Trans.Class
@@ -61,17 +60,25 @@ import Data.Either
6160
import Data.List.Extra (dropEnd1, nubOrd)
6261

6362

63+
import Control.Lens ((^.))
6464
import Data.Either.Extra (eitherToMaybe)
6565
import Data.List (isSuffixOf, sortOn)
66+
import Data.Set (Set)
67+
import qualified Data.Set as S
6668
import Data.Tree
6769
import qualified Data.Tree as T
6870
import Data.Version (showVersion)
71+
import Development.IDE.Core.LookupMod (LookupModule, lookupMod)
72+
import Development.IDE.Core.Shake (ShakeExtras (..),
73+
runIdeAction)
6974
import Development.IDE.Types.Shake (WithHieDb)
7075
import GHC.Iface.Ext.Types (EvVarSource (..),
7176
HieAST (..),
7277
HieASTs (..),
7378
HieArgs (..),
74-
HieType (..), Identifier,
79+
HieType (..),
80+
HieTypeFix (..),
81+
Identifier,
7582
IdentifierDetails (..),
7683
NodeInfo (..), Scope,
7784
Span)
@@ -86,12 +93,9 @@ import GHC.Iface.Ext.Utils (EvidenceInfo (..),
8693
selectSmallestContaining)
8794
import HieDb hiding (pointCommand,
8895
withHieDb)
96+
import qualified Language.LSP.Protocol.Lens as L
8997
import System.Directory (doesFileExist)
9098

91-
-- | Gives a Uri for the module, given the .hie file location and the the module info
92-
-- The Bool denotes if it is a boot module
93-
type LookupModule m = FilePath -> ModuleName -> Unit -> Bool -> MaybeT m Uri
94-
9599
-- | HieFileResult for files of interest, along with the position mappings
96100
newtype FOIReferences = FOIReferences (HM.HashMap NormalizedFilePath (HieAstResult, PositionMapping))
97101

@@ -251,31 +255,41 @@ gotoImplementation withHieDb getHieFile ideOpts srcSpans pos
251255
-- | Synopsis for the name at a given position.
252256
atPoint
253257
:: IdeOptions
258+
-> ShakeExtras
254259
-> HieAstResult
255260
-> DocAndTyThingMap
256261
-> HscEnv
257262
-> Position
258263
-> IO (Maybe (Maybe Range, [T.Text]))
259-
atPoint IdeOptions{} (HAR _ (hf :: HieASTs a) rf _ (kind :: HieKind hietype)) (DKMap dm km _am) env pos =
264+
atPoint opts@IdeOptions{} shakeExtras@ShakeExtras{ withHieDb, hiedbWriter } har@(HAR _ (hf :: HieASTs a) rf _ (kind :: HieKind hietype)) (DKMap dm km _am) env pos =
260265
listToMaybe <$> sequence (pointCommand hf pos hoverInfo)
261266
where
262267
-- Hover info for values/data
263268
hoverInfo :: HieAST hietype -> IO (Maybe Range, [T.Text])
264269
hoverInfo ast = do
265-
prettyNames <- mapM prettyName names
266-
pure (Just range, prettyNames ++ pTypes)
270+
locationsWithIdentifier <- runIdeAction "TypeCheck" shakeExtras $ do
271+
runMaybeT $ gotoTypeDefinition withHieDb (lookupMod hiedbWriter) opts har pos
272+
273+
let locationsMap = M.fromList $ mapMaybe (\(loc, identifier) -> case identifier of
274+
Right typeName ->
275+
-- Filter out type variables (polymorphic names like 'a', 'b', etc.)
276+
if isTyVarName typeName
277+
then Nothing
278+
else Just (typeName, loc)
279+
Left _moduleName -> Nothing) $ fromMaybe [] locationsWithIdentifier
280+
281+
prettyNames <- mapM (prettyName locationsMap) names
282+
pure (Just range, prettyNames ++ pTypes locationsMap)
267283
where
268-
pTypes :: [T.Text]
269-
pTypes
270-
| Prelude.length names == 1 = dropEnd1 $ map wrapHaskell prettyTypes
271-
| otherwise = map wrapHaskell prettyTypes
284+
pTypes :: M.Map Name Location -> [T.Text]
285+
pTypes locationsMap =
286+
case names of
287+
[_singleName] -> dropEnd1 $ prettyTypes Nothing locationsMap
288+
_ -> prettyTypes Nothing locationsMap
272289

273290
range :: Range
274291
range = realSrcSpanToRange $ nodeSpan ast
275292

276-
wrapHaskell :: T.Text -> T.Text
277-
wrapHaskell x = "\n```haskell\n"<>x<>"\n```\n"
278-
279293
info :: NodeInfo hietype
280294
info = nodeInfoH kind ast
281295

@@ -284,8 +298,8 @@ atPoint IdeOptions{} (HAR _ (hf :: HieASTs a) rf _ (kind :: HieKind hietype)) (D
284298
names :: [(Identifier, IdentifierDetails hietype)]
285299
names = sortOn (any isEvidenceUse . identInfo . snd) $ M.assocs $ nodeIdentifiers info
286300

287-
prettyName :: (Either ModuleName Name, IdentifierDetails hietype) -> IO T.Text
288-
prettyName (Right n, dets)
301+
prettyName :: M.Map Name Location -> (Either ModuleName Name, IdentifierDetails hietype) -> IO T.Text
302+
prettyName locationsMap (Right n, dets)
289303
-- We want to print evidence variable using a readable tree structure.
290304
-- Evidence variables contain information why a particular instance or
291305
-- type equality was chosen, paired with location information.
@@ -299,20 +313,23 @@ atPoint IdeOptions{} (HAR _ (hf :: HieASTs a) rf _ (kind :: HieKind hietype)) (D
299313
pure $ evidenceTree <> "\n"
300314
-- Identifier details that are not evidence variables are used to display type information and
301315
-- documentation of that name.
302-
| otherwise =
316+
| otherwise = do
303317
let
304-
typeSig = wrapHaskell (printOutputable n <> maybe "" (" :: " <>) ((prettyType <$> identType dets) <|> maybeKind))
318+
typeSig = case identType dets of
319+
Just t -> prettyType (Just n) locationsMap t
320+
Nothing -> case safeTyThingType =<< lookupNameEnv km n of
321+
Just kind -> prettyTypeFromType (Just n) locationsMap kind
322+
Nothing -> wrapHaskell (printOutputable n)
305323
definitionLoc = maybeToList (pretty (definedAt n) (prettyPackageName n))
306324
docs = maybeToList (T.unlines . spanDocToMarkdown <$> lookupNameEnv dm n)
307-
in
308-
pure $ T.unlines $
309-
[typeSig] ++ definitionLoc ++ docs
310-
where maybeKind = fmap printOutputable $ safeTyThingType =<< lookupNameEnv km n
325+
326+
pure $ T.unlines $ [typeSig] ++ definitionLoc ++ docs
327+
where
311328
pretty Nothing Nothing = Nothing
312329
pretty (Just define) Nothing = Just $ define <> "\n"
313330
pretty Nothing (Just pkgName) = Just $ pkgName <> "\n"
314331
pretty (Just define) (Just pkgName) = Just $ define <> " " <> pkgName <> "\n"
315-
prettyName (Left m,_) = packageNameForImportStatement m
332+
prettyName _locationsMap (Left m,_) = packageNameForImportStatement m
316333

317334
prettyPackageName :: Name -> Maybe T.Text
318335
prettyPackageName n = do
@@ -345,11 +362,63 @@ atPoint IdeOptions{} (HAR _ (hf :: HieASTs a) rf _ (kind :: HieKind hietype)) (D
345362
types :: [hietype]
346363
types = nodeType info
347364

348-
prettyTypes :: [T.Text]
349-
prettyTypes = map (("_ :: "<>) . prettyType) types
365+
prettyTypes :: Maybe Name -> M.Map Name Location -> [T.Text]
366+
prettyTypes boundNameMay locationsMap =
367+
map (prettyType boundNameMay locationsMap) types
368+
369+
prettyTypeFromType :: Maybe Name -> M.Map Name Location -> Type -> T.Text
370+
prettyTypeFromType boundNameMay locationsMap ty =
371+
prettyTypeCommon boundNameMay locationsMap (S.fromList $ namesInType ty) (printOutputable ty)
372+
373+
prettyType :: Maybe Name -> M.Map Name Location -> hietype -> T.Text
374+
prettyType boundNameMay locationsMap t =
375+
prettyTypeCommon boundNameMay locationsMap (typeNames t) (printOutputable . expandType $ t)
376+
377+
prettyTypeCommon :: Maybe Name -> M.Map Name Location -> Set Name -> T.Text -> T.Text
378+
prettyTypeCommon boundNameMay locationsMap names expandedType =
379+
let nameToUse = case boundNameMay of
380+
Just n -> printOutputable n
381+
Nothing -> "_"
382+
expandedWithName = nameToUse <> " :: " <> expandedType
383+
codeBlock = wrapHaskell expandedWithName
384+
links = case boundNameMay of
385+
Just _ -> generateLinksList locationsMap names
386+
-- This is so we don't get flooded with links, e.g:
387+
-- foo :: forall a. MyType a -> a
388+
-- Go to MyType
389+
-- _ :: forall a. MyType a -> a
390+
-- Go to MyType -- <- we don't want this as it's already present
391+
Nothing -> ""
392+
in codeBlock <> links
393+
394+
generateLinksList :: M.Map Name Location -> Set Name -> T.Text
395+
generateLinksList locationsMap (S.toList -> names) =
396+
if null generated
397+
then ""
398+
else "\n" <> "Go to " <> T.intercalate " | " generated <> "\n"
399+
where
400+
generated = mapMaybe generateLink names
350401

351-
prettyType :: hietype -> T.Text
352-
prettyType = printOutputable . expandType
402+
generateLink name = do
403+
case M.lookup name locationsMap of
404+
Just (Location uri range) ->
405+
let nameText = printOutputable name
406+
link = "[" <> nameText <> "](" <> getUriText uri <> "#L" <>
407+
T.pack (show (range ^. L.start . L.line + 1)) <> ")"
408+
in Just link
409+
Nothing -> Nothing
410+
411+
wrapHaskell :: T.Text -> T.Text
412+
wrapHaskell x = "\n```haskell\n"<>x<>"\n```\n"
413+
414+
getUriText :: Uri -> T.Text
415+
getUriText (Uri t) = t
416+
417+
typeNames :: a -> Set Name
418+
typeNames t = S.fromList $ case kind of
419+
HieFresh -> namesInType t
420+
HieFromDisk full_file -> do
421+
namesInHieTypeFix $ recoverFullType t (hie_types full_file)
353422

354423
expandType :: a -> SDoc
355424
expandType t = case kind of
@@ -468,9 +537,24 @@ namesInType (CastTy t _) = namesInType t
468537
namesInType (LitTy _) = []
469538
namesInType _ = []
470539

540+
471541
getTypes :: [Type] -> [Name]
472542
getTypes = concatMap namesInType
473543

544+
namesInHieTypeFix :: HieTypeFix -> [Name]
545+
namesInHieTypeFix (Roll hieType) = namesInHieType hieType
546+
547+
namesInHieType :: HieType HieTypeFix -> [Name]
548+
namesInHieType (HTyVarTy n) = [n]
549+
namesInHieType (HAppTy a (HieArgs args)) = namesInHieTypeFix a ++ concatMap (namesInHieTypeFix . snd) args
550+
namesInHieType (HTyConApp tc (HieArgs args)) = ifaceTyConName tc : concatMap (namesInHieTypeFix . snd) args
551+
namesInHieType (HForAllTy ((binder, constraint), _) body) = binder : namesInHieTypeFix constraint ++ namesInHieTypeFix body
552+
namesInHieType (HFunTy mult arg res) = namesInHieTypeFix mult ++ namesInHieTypeFix arg ++ namesInHieTypeFix res
553+
namesInHieType (HQualTy constraint body) = namesInHieTypeFix constraint ++ namesInHieTypeFix body
554+
namesInHieType (HLitTy _) = []
555+
namesInHieType (HCastTy a) = namesInHieTypeFix a
556+
namesInHieType HCoercionTy = []
557+
474558
-- | Find 'Location's of definition at a specific point and return them along with their 'Identifier's.
475559
locationsAtPoint
476560
:: forall m

0 commit comments

Comments
 (0)