Add links to haddock and hscolour pages in documentation (#699)

Currently this only searches local documentation (generated with
`cabal haddock --haddock-hyperlink-source` or equivalent) but could be
extended to support searching via Hoogle in the future. And it works for
any of the core libraries since they come installed with documentation.
Will show up in hover and (non-local) completions.

Also fixes extra markdown horizontal rules being inserted with no
content in between them.

src/Development/IDE/Plugin/Completions/Logic.hs

@@ -352,7 +352,7 @@ localCompletionsForParsedModule pm@ParsedModule{pm_parsed_source = L _ HsModule{
         CI ctyp pn thisModName ty pn Nothing doc (ctyp `elem` [CiStruct, CiClass])
       where
         pn = ppr n
-        doc = SpanDocText $ getDocumentation [pm] n
+        doc = SpanDocText (getDocumentation [pm] n) (SpanDocUris Nothing Nothing)
 
     thisModName = ppr hsmodName
 

src/Development/IDE/Spans/AtPoint.hs

@@ -17,10 +17,9 @@ import Development.IDE.Types.Location
 import Development.IDE.GHC.Compat
 import Development.IDE.Types.Options
 import Development.IDE.Spans.Type as SpanInfo
-import Development.IDE.Spans.Common (spanDocToMarkdown)
+import Development.IDE.Spans.Common (showName, spanDocToMarkdown)
 
 -- GHC API imports
-import DynFlags
 import FastString
 import Name
 import Outputable hiding ((<>))
@@ -66,7 +65,10 @@ atPoint
 atPoint IdeOptions{..} (SpansInfo srcSpans cntsSpans) pos = do
     firstSpan <- listToMaybe $ deEmpasizeGeneratedEqShow $ spansAtPoint pos srcSpans
     let constraintsAtPoint = mapMaybe spaninfoType (spansAtPoint pos cntsSpans)
-    return (Just (range firstSpan), hoverInfo firstSpan constraintsAtPoint)
+        -- Filter out the empty lines so we don't end up with a bunch of
+        -- horizontal separators with nothing inside of them
+        text = filter (not . T.null) $ hoverInfo firstSpan constraintsAtPoint
+    return (Just (range firstSpan), text)
   where
     -- Hover info for types, classes, type variables
     hoverInfo SpanInfo{spaninfoType = Nothing , spaninfoDocs = docs ,  ..} _ =
@@ -212,11 +214,6 @@ spansAtPoint pos = filter atp where
                                               -- last character so we use > instead of >=
       endsAfterPosition = endLineCmp == GT || (endLineCmp == EQ && spaninfoEndCol > cha)
 
-showName :: Outputable a => a -> T.Text
-showName = T.pack . prettyprint
-  where
-    prettyprint x = renderWithStyle unsafeGlobalDynFlags (ppr x) style
-    style = mkUserStyle unsafeGlobalDynFlags neverQualify AllTheWay
 
 getModuleNameAsText :: Name -> Maybe T.Text
 getModuleNameAsText n = do

src/Development/IDE/Spans/Common.hs

@@ -3,11 +3,13 @@
 
 module Development.IDE.Spans.Common (
   showGhc
+, showName
 , listifyAllSpans
 , listifyAllSpans'
 , safeTyThingId
 , safeTyThingType
 , SpanDoc(..)
+, SpanDocUris(..)
 , emptySpanDoc
 , spanDocToMarkdown
 , spanDocToMarkdownForTest
@@ -15,11 +17,12 @@ module Development.IDE.Spans.Common (
 
 import Data.Data
 import qualified Data.Generics
+import Data.Maybe
 import qualified Data.Text as T
 import Data.List.Extra
 
 import GHC
-import Outputable
+import Outputable hiding ((<>))
 import DynFlags
 import ConLike
 import DataCon
@@ -31,6 +34,12 @@ import qualified Documentation.Haddock.Types as H
 showGhc :: Outputable a => a -> String
 showGhc = showPpr unsafeGlobalDynFlags
 
+showName :: Outputable a => a -> T.Text
+showName = T.pack . prettyprint
+  where
+    prettyprint x = renderWithStyle unsafeGlobalDynFlags (ppr x) style
+    style = mkUserStyle unsafeGlobalDynFlags neverQualify AllTheWay
+
 -- | Get ALL source spans in the source.
 listifyAllSpans :: (Typeable a, Data m) => m -> [Located a]
 listifyAllSpans tcs =
@@ -57,22 +66,38 @@ safeTyThingId _                           = Nothing
 
 -- Possible documentation for an element in the code
 data SpanDoc
-  = SpanDocString HsDocString
-  | SpanDocText   [T.Text]
+  = SpanDocString HsDocString SpanDocUris
+  | SpanDocText   [T.Text] SpanDocUris
   deriving (Eq, Show)
 
+data SpanDocUris =
+  SpanDocUris
+  { spanDocUriDoc :: Maybe T.Text -- ^ The haddock html page
+  , spanDocUriSrc :: Maybe T.Text -- ^ The hyperlinked source html page
+  } deriving (Eq, Show)
+
 emptySpanDoc :: SpanDoc
-emptySpanDoc = SpanDocText []
+emptySpanDoc = SpanDocText [] (SpanDocUris Nothing Nothing)
 
 spanDocToMarkdown :: SpanDoc -> [T.Text]
 #if MIN_GHC_API_VERSION(8,6,0)
-spanDocToMarkdown (SpanDocString docs)
+spanDocToMarkdown (SpanDocString docs uris)
   = [T.pack $ haddockToMarkdown $ H.toRegular $ H._doc $ H.parseParas Nothing $ unpackHDS docs]
+    <> ["\n"] <> spanDocUrisToMarkdown uris
+  -- Append the extra newlines since this is markdown --- to get a visible newline,
+  -- you need to have two newlines
 #else
-spanDocToMarkdown (SpanDocString _)
-  = []
+spanDocToMarkdown (SpanDocString _ uris)
+  = spanDocUrisToMarkdown uris
 #endif
-spanDocToMarkdown (SpanDocText txt) = txt
+spanDocToMarkdown (SpanDocText txt uris) = txt <> ["\n"] <> spanDocUrisToMarkdown uris
+
+spanDocUrisToMarkdown :: SpanDocUris -> [T.Text]
+spanDocUrisToMarkdown (SpanDocUris mdoc msrc) = catMaybes
+  [ linkify "Documentation" <$> mdoc
+  , linkify "Source" <$> msrc
+  ]
+  where linkify title uri = "[" <> title <> "](" <> uri <> ")"
 
 spanDocToMarkdownForTest :: String -> String
 spanDocToMarkdownForTest

src/Development/IDE/Spans/Documentation.hs

@@ -12,6 +12,7 @@ module Development.IDE.Spans.Documentation (
   ) where
 
 import           Control.Monad
+import           Data.Foldable
 import           Data.List.Extra
 import qualified Data.Map as M
 import           Data.Maybe
@@ -22,8 +23,14 @@ import           Development.IDE.Core.Compile
 import           Development.IDE.GHC.Compat
 import           Development.IDE.GHC.Error
 import           Development.IDE.Spans.Common
+import           System.Directory
+import           System.FilePath
+
 import           FastString
 import           SrcLoc (RealLocated)
+import           GhcMonad
+import           Packages
+import           Name
 
 getDocumentationTryGhc :: GhcMonad m => Module -> [ParsedModule] -> Name -> m SpanDoc
 getDocumentationTryGhc mod deps n = head <$> getDocumentationsTryGhc mod deps [n]
@@ -36,15 +43,35 @@ getDocumentationsTryGhc :: GhcMonad m => Module -> [ParsedModule] -> [Name] -> m
 getDocumentationsTryGhc mod sources names = do
   res <- catchSrcErrors "docs" $ getDocsBatch mod names
   case res of
-      Left _ -> return $ map (SpanDocText . getDocumentation sources) names
-      Right res -> return $ zipWith unwrap res names
+      Left _ -> mapM mkSpanDocText names
+      Right res -> zipWithM unwrap res names
   where
-    unwrap (Right (Just docs, _))  _= SpanDocString docs
-    unwrap _ n = SpanDocText $ getDocumentation sources n
+    unwrap (Right (Just docs, _)) n = SpanDocString <$> pure docs <*> getUris n
+    unwrap _ n = mkSpanDocText n
+
 #else
-getDocumentationsTryGhc _ sources names = do
-  return $ map (SpanDocText . getDocumentation sources) names
+getDocumentationsTryGhc _ sources names = mapM mkSpanDocText names
+  where
 #endif
+    mkSpanDocText name =
+      pure (SpanDocText (getDocumentation sources name)) <*> getUris name
+
+    -- Get the uris to the documentation and source html pages if they exist
+    getUris name = do
+      df <- getSessionDynFlags
+      (docFp, srcFp) <-
+        case nameModule_maybe name of
+          Just mod -> liftIO $ do
+            doc <- fmap (fmap T.pack) $ lookupDocHtmlForModule df mod
+            src <- fmap (fmap T.pack) $ lookupSrcHtmlForModule df mod
+            return (doc, src)
+          Nothing -> pure (Nothing, Nothing)
+      let docUri = docFp >>= \fp -> pure $ "file://" <> fp <> "#" <> selector <> showName name
+          srcUri = srcFp >>= \fp -> pure $ "file://" <> fp <> "#" <> showName name
+          selector
+            | isValName name = "v:"
+            | otherwise = "t:"
+      return $ SpanDocUris docUri srcUri
 
 
 getDocumentation
@@ -122,3 +149,34 @@ docHeaders = mapMaybe (\(L _ x) -> wrk x)
                             then Just $ T.pack s
                             else Nothing
     _ -> Nothing
+
+-- These are taken from haskell-ide-engine's Haddock plugin
+
+-- | Given a module finds the local @doc/html/Foo-Bar-Baz.html@ page.
+-- An example for a cabal installed module:
+-- @~/.cabal/store/ghc-8.10.1/vctr-0.12.1.2-98e2e861/share/doc/html/Data-Vector-Primitive.html@
+lookupDocHtmlForModule :: DynFlags -> Module -> IO (Maybe FilePath)
+lookupDocHtmlForModule =
+  lookupHtmlForModule (\pkgDocDir modDocName -> pkgDocDir </> modDocName <.> "html")
+
+-- | Given a module finds the hyperlinked source @doc/html/src/Foo.Bar.Baz.html@ page.
+-- An example for a cabal installed module:
+-- @~/.cabal/store/ghc-8.10.1/vctr-0.12.1.2-98e2e861/share/doc/html/src/Data.Vector.Primitive.html@
+lookupSrcHtmlForModule :: DynFlags -> Module -> IO (Maybe FilePath)
+lookupSrcHtmlForModule =
+  lookupHtmlForModule (\pkgDocDir modDocName -> pkgDocDir </> "src" </> modDocName <.> "html")
+
+lookupHtmlForModule :: (FilePath -> FilePath -> FilePath) -> DynFlags -> Module -> IO (Maybe FilePath)
+lookupHtmlForModule mkDocPath df m = do
+  let mfs = go <$> (listToMaybe =<< lookupHtmls df ui)
+  htmls <- filterM doesFileExist (concat . maybeToList $ mfs)
+  return $ listToMaybe htmls
+  where
+    -- The file might use "." or "-" as separator
+    go pkgDocDir = [mkDocPath pkgDocDir mn | mn <- [mndot,mndash]]
+    ui = moduleUnitId m
+    mndash = map (\x -> if x == '.' then '-' else x) mndot
+    mndot = moduleNameString $ moduleName m
+
+lookupHtmls :: DynFlags -> UnitId -> Maybe [FilePath]
+lookupHtmls df ui = haddockHTMLs <$> lookupPackage df ui

test/exe/Main.hs

@@ -1833,6 +1833,7 @@ findDefinitionAndHoverTests = let
   lstL43 = Position 47 12  ;  litL   = [ExpectHoverText ["[8391 :: Int, 6268]"]]
   outL45 = Position 49  3  ;  outSig = [ExpectHoverText ["outer", "Bool"], mkR 46 0 46 5]
   innL48 = Position 52  5  ;  innSig = [ExpectHoverText ["inner", "Char"], mkR 49 2 49 7]
+  cccL17 = Position 17 11  ;  docLink = [ExpectHoverText ["[Documentation](file://"]]
 #if MIN_GHC_API_VERSION(8,6,0)
   imported = Position 56 13 ; importedSig = getDocUri "Foo.hs" >>= \foo -> return [ExpectHoverText ["foo", "Foo", "Haddock"], mkL foo 5 0 5 3]
   reexported = Position 55 14 ; reexportedSig = getDocUri "Bar.hs" >>= \bar -> return [ExpectHoverText ["Bar", "Bar", "Haddock"], mkL bar 3 0 3 14]
@@ -1842,7 +1843,7 @@ findDefinitionAndHoverTests = let
 #endif
   in
   mkFindTests
-  --     def    hover  look       expect
+  --      def    hover  look       expect
   [ test  yes    yes    fffL4      fff           "field in record definition"
   , test  broken broken fffL8      fff           "field in record construction     #71"
   , test  yes    yes    fffL14     fff           "field name used as accessor"          -- 120 in Calculate.hs
@@ -1878,6 +1879,7 @@ findDefinitionAndHoverTests = let
   , test  no     yes    docL41     constr        "type constraint in hover info   #283"
   , test  broken broken outL45     outSig        "top-level signature             #310"
   , test  broken broken innL48     innSig        "inner     signature             #310"
+  , test  no     yes    cccL17     docLink       "Haddock html links"
   , testM yes    yes    imported   importedSig   "Imported symbol"
   , testM yes    yes    reexported reexportedSig "Imported symbol (reexported)"
   ]