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

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

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.

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