Skip to content
This repository has been archived by the owner on Jan 2, 2021. It is now read-only.

Add links to haddock and hscolour pages in documentation #699

Merged
merged 1 commit into from
Jul 27, 2020
Merged

Add links to haddock and hscolour pages in documentation #699

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
2 changes: 1 addition & 1 deletion src/Development/IDE/Plugin/Completions/Logic.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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

Expand Down
13 changes: 5 additions & 8 deletions src/Development/IDE/Spans/AtPoint.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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 ((<>))
Expand Down Expand Up @@ -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 , ..} _ =
Expand Down Expand Up @@ -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
Expand Down
41 changes: 33 additions & 8 deletions src/Development/IDE/Spans/Common.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -3,23 +3,26 @@

module Development.IDE.Spans.Common (
showGhc
, showName
, listifyAllSpans
, listifyAllSpans'
, safeTyThingId
, safeTyThingType
, SpanDoc(..)
, SpanDocUris(..)
, emptySpanDoc
, spanDocToMarkdown
, spanDocToMarkdownForTest
) where

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
Expand All @@ -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 =
Expand All @@ -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
Expand Down
70 changes: 64 additions & 6 deletions src/Development/IDE/Spans/Documentation.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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]
Expand All @@ -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
Copy link
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

This requires calling into IO, which means now that after lukel97@7dc6e26 I'm not sure how to integrate this with doc local completions, which seems to be a function purely based off of the ParsedModule cc @pepeiborra

Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Local completions can use IO so I presume that's not what is blocking you.

Local completions do not use the ghc api to extract documentation, i.e. they do not call getDocumentationTryGhc, since that requires a ModIface which is only available after type checking. Instead, they get the documentation from the parse tree by calling D.IDE.Spans.Documentation.getDocumentation.

So I think the problem is that there are two code paths to get documentation and this PR needs to be extended to cover both.

Copy link
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

It also needs to get access to the DynFlags which I'm not sure how to get outside of the GHC session, i.e. in getDocumentation. In localCompletionsForParsedModule

Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Do we want to run this code for local completions anyway? Locally defined identifiers will not have any documentation links

Copy link
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Yeah I was thinking that too. The PR currently just ignores it in Logic.hs:

    mkComp n ctyp ty =
         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)

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
Expand Down Expand Up @@ -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
6 changes: 4 additions & 2 deletions test/exe/Main.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -1261,7 +1261,7 @@ addTypeAnnotationsToLiteralsTest = testGroup "add type annotations to literals t
, ""
, "import Debug.Trace"
, ""
, "f a = traceShow \"debug\" a"
, "f a = traceShow \"debug\" a"
])
[ (DsWarning, (6, 6), "Defaulting the following constraint") ]
"Add type annotation ‘[Char]’ to ‘\"debug\"’"
Expand Down Expand Up @@ -1754,6 +1754,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]
Expand All @@ -1763,7 +1764,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
Expand Down Expand Up @@ -1799,6 +1800,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)"
]
Expand Down