Add pretty link for source location to hover

Author: fendor

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

@@ -69,6 +69,7 @@ import           Development.IDE.Types.Shake          (WithHieDb)
 import           HieDb                                hiding (pointCommand,
                                                        withHieDb)
 import           System.Directory                     (doesFileExist)
+import Debug.Trace
 
 -- | 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
@@ -335,7 +336,7 @@ atPoint IdeOptions{} (HAR _ (hf :: HieASTs a) rf _ (kind :: HieKind hietype)) (D
         -- We want to render the root constraint even if it is a let,
         -- but we don't want to render any subsequent lets
         renderEvidenceTree :: Tree (EvidenceInfo a) -> SDoc
-        -- However, if the root constraint is simply an indirection (via let) to a single other constraint,
+        -- However, if the root constraint is simply a<n indirection (via let) to a single other constraint,
         -- we can still skip rendering it
         renderEvidenceTree (T.Node (EvidenceInfo{evidenceDetails=Just (EvLetBind _,_,_)}) [x])
           = renderEvidenceTree x
@@ -351,13 +352,15 @@ atPoint IdeOptions{} (HAR _ (hf :: HieASTs a) rf _ (kind :: HieKind hietype)) (D
           = vcat (map renderEvidenceTree' xs)
         renderEvidenceTree' (T.Node (EvidenceInfo{..}) _)
           = hang (text "- `" O.<> expandType evidenceType O.<> "`") 2 $
-                 vcat $ printDets evidenceSpan evidenceDetails : map (text . T.unpack) (maybeToList $ definedAt evidenceVar)
+                 vcat $
+                    printDets evidenceSpan evidenceDetails : map (text . T.unpack) (maybeToList $ definedAt evidenceVar)
 
         printDets :: RealSrcSpan -> Maybe (EvVarSource, Scope, Maybe Span) -> SDoc
         printDets _    Nothing = text "using an external instance"
         printDets ospn (Just (src,_,mspn)) = pprSrc
-                                      $$ text "at" <+> ppr spn
+                                      $$ text "at" <+> text (T.unpack $ srcSpanToMdLink location)
           where
+            location = realSrcSpanToLocation $ traceShowId spn
             -- Use the bind span if we have one, else use the occurrence span
             spn = fromMaybe ospn mspn
             pprSrc = case src of

ghcide/src/Development/IDE/Spans/Common.hs

@@ -13,22 +13,28 @@ module Development.IDE.Spans.Common (
 , spanDocToMarkdownForTest
 , DocMap
 , TyThingMap
+, srcSpanToMdLink
 ) where
 
 import           Control.DeepSeq
+import           Data.Bifunctor                  (second)
 import           Data.List.Extra
 import           Data.Maybe
-import qualified Data.Text                    as T
-import           GHC.Generics
-
+import qualified Data.Text                       as T
+import           Development.IDE.GHC.Util
+import qualified Documentation.Haddock.Parser    as H
+import qualified Documentation.Haddock.Types     as H
 import           GHC
+import           GHC.Generics
+import           System.FilePath
 
-import           Data.Bifunctor               (second)
 import           Development.IDE.GHC.Compat
-import           Development.IDE.GHC.Orphans  ()
-import           Development.IDE.GHC.Util
-import qualified Documentation.Haddock.Parser as H
-import qualified Documentation.Haddock.Types  as H
+import qualified Development.IDE.GHC.Compat.Util as Util
+import           Development.IDE.GHC.Orphans     ()
+import Language.LSP.Protocol.Types
+import qualified Language.LSP.Protocol.Lens as JL
+import Control.Lens
+import Language.LSP.Protocol.Lens (HasUri(uri))
 
 type DocMap = NameEnv SpanDoc
 type TyThingMap = NameEnv TyThing
@@ -109,7 +115,13 @@ spanDocUrisToMarkdown (SpanDocUris mdoc msrc) = catMaybes
   [ linkify "Documentation" <$> mdoc
   , linkify "Source" <$> msrc
   ]
-  where linkify title uri = "[" <> title <> "](" <> uri <> ")"
+
+-- | Generate a markdown link.
+--
+-- >>> linkify "Title" "uri"
+-- "[Title](Uri)"
+linkify :: T.Text -> T.Text -> T.Text
+linkify title uri = "[" <> title <> "](" <> uri <> ")"
 
 spanDocToMarkdownForTest :: String -> String
 spanDocToMarkdownForTest
@@ -215,3 +227,35 @@ splitForList s
   = case lines s of
       []           -> ""
       (first:rest) -> unlines $ first : map (("  " ++) . trimStart) rest
+
+-- | Generate a source link for the 'Location' according to VSCode's supported form:
+-- https://github.com/microsoft/vscode/blob/b3ec8181fc49f5462b5128f38e0723ae85e295c2/src/vs/platform/opener/common/opener.ts#L151-L160
+--
+srcSpanToMdLink :: Location -> T.Text
+srcSpanToMdLink location =
+  let
+    uri = location ^. JL.uri
+    range = location ^. JL.range
+    -- LSP 'Range' starts at '0', but link locations start at '1'.
+    intText n = T.pack $ show (n + 1)
+    srcRangeText =
+      T.concat
+        [ "L"
+        , intText (range ^. JL.start . JL.line)
+        , ","
+        , intText (range ^. JL.start . JL.character)
+        , "-L"
+        , intText (range ^. JL.end . JL.line)
+        , ","
+        , intText (range ^. JL.end . JL.character)
+        ]
+
+    -- If the 'Location' is a 'FilePath', display it in shortened form.
+    -- This avoids some redundancy and better readability for the user.
+    title = case uriToFilePath uri of
+      Just fp -> T.pack (takeFileName fp) <> ":" <> intText (range ^. JL.start . JL.line)
+      Nothing -> getUri uri
+
+    srcLink = getUri uri <> "#" <> srcRangeText
+  in
+   linkify title srcLink