diff --git a/src/Development/IDE/Plugin/Completions/Logic.hs b/src/Development/IDE/Plugin/Completions/Logic.hs index dfff882ae..07fc36101 100644 --- a/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/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 diff --git a/src/Development/IDE/Spans/AtPoint.hs b/src/Development/IDE/Spans/AtPoint.hs index b6f1344c5..58ea5760c 100644 --- a/src/Development/IDE/Spans/AtPoint.hs +++ b/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 diff --git a/src/Development/IDE/Spans/Common.hs b/src/Development/IDE/Spans/Common.hs index a1c4d02ee..451cc200b 100644 --- a/src/Development/IDE/Spans/Common.hs +++ b/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 diff --git a/src/Development/IDE/Spans/Documentation.hs b/src/Development/IDE/Spans/Documentation.hs index 6f80884ae..5294ba489 100644 --- a/src/Development/IDE/Spans/Documentation.hs +++ b/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 diff --git a/test/exe/Main.hs b/test/exe/Main.hs index 5d4fae02a..d49b2d232 100644 --- a/test/exe/Main.hs +++ b/test/exe/Main.hs @@ -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\"’" @@ -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] @@ -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 @@ -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)" ]