Add "Go to type" hyperlinks in the hover popup (like Rust has) (#4691)

* Add "Go to type" hyperlinks in the hover popup. * Get rid of redundant dropEnd1 * Actually realize that the dropEnd1 is old code and revert "Get rid of redundant dropEnd1" This reverts commit 723d56c. * Add tests for the 'Go to' links in the hover. * Cap the number of types to 10.

Author: dnikolovv

ghcide-test/exe/FindDefinitionAndHoverTests.hs

@@ -146,6 +146,9 @@ tests = let
  fffL14 = Position 18 7 ;
  aL20 = Position 19 15
  aaaL14 = Position 18 20 ; aaa = [mkR 11 0 11 3]
+ kkkL30 = Position 30 2 ; kkkType = [ExpectHoverTextRegex "Go to \\[MyClass\\]\\(.*GotoHover\\.hs#L26\\)"]
+ bbbL16 = Position 16 7 ; bbbType = [ExpectHoverTextRegex "Go to \\[TypeConstructor\\]\\(.*GotoHover\\.hs#L8\\)"]
+ aaaL11 = Position 11 1 ; aaaType = [ExpectHoverTextRegex "Go to \\[TypeConstructor\\]\\(.*GotoHover\\.hs#L8\\)"]
  dcL7 = Position 11 11 ; tcDC = [mkR 7 23 9 16]
  dcL12 = Position 16 11 ;
  xtcL5 = Position 9 11 ; xtc = [ExpectHoverText ["Int", "Defined in ", "GHC.Types", "ghc-prim"]]
@@ -243,6 +246,9 @@ tests = let
  testM yes yes reexported reexportedSig "Imported symbol reexported"
  , test no yes thLocL57 thLoc "TH Splice Hover"
  , test yes yes import310 pkgTxt "show package name and its version"
+ , test no yes kkkL30 kkkType "hover shows 'Go to' link for class in constraint"
+ , test no yes bbbL16 bbbType "hover shows 'Go to' link for data constructor's type"
+ , test no yes aaaL11 aaaType "hover shows 'Go to' link for binding's underlying type"
  ]
  where yes :: (TestTree -> Maybe TestTree)
  yes = Just -- test should run and pass

ghcide/ghcide.cabal

@@ -133,6 +133,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

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 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.

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

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

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 _am) env pos =
+atPoint opts@IdeOptions{} shakeExtras@ShakeExtras{ withHieDb, hiedbWriter } har@(HAR _ (hf :: HieASTs a) rf _ (kind :: HieKind hietype)) (DKMap dm km _am) 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
@@ -343,13 +360,68 @@ atPoint IdeOptions{} (HAR _ (hf :: HieASTs a) rf _ (kind :: HieKind hietype)) (D
  -- Type info for the current node, it may contain several symbols
  -- for one range, like wildcard
  types :: [hietype]
- types = nodeType info
+ types = take maxHoverTypes $ nodeType info
+
+ maxHoverTypes :: Int
+ maxHoverTypes = 10
+
+ 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
+
+ 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
 
- prettyTypes :: [T.Text]
- prettyTypes = map (("_ :: "<>) . prettyType) types
+ wrapHaskell :: T.Text -> T.Text
+ wrapHaskell x = "\n```haskell\n"<>x<>"\n```\n"
 
- prettyType :: hietype -> T.Text
- prettyType = printOutputable . expandType
+ 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 +540,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