From d58bcf24dfa4333e7893935eb86c036be28125b1 Mon Sep 17 00:00:00 2001 From: Łukasz Hanuszczak Date: Fri, 26 Jun 2015 22:41:07 +0200 Subject: Make external hyperlinks point to locations specified by source URLs. --- haddock-api/src/Haddock.hs | 7 ++- haddock-api/src/Haddock/Backends/Hyperlinker.hs | 8 ++-- .../src/Haddock/Backends/Hyperlinker/Renderer.hs | 52 +++++++++++++--------- haddock-api/src/Haddock/Utils.hs | 5 ++- 4 files changed, 44 insertions(+), 28 deletions(-) diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 01e4cd45..3105edf5 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -264,7 +264,12 @@ render dflags flags qual ifaces installedIfaces srcMap = do | Flag_HyperlinkedSource `elem` flags = Just defaultModuleSourceUrl | otherwise = Nothing - srcMap' = maybe srcMap (\path -> Map.insert pkgKey path srcMap) srcEntity + srcMap' + | Just srcNameUrl <- srcEntity = Map.insert pkgKey srcNameUrl srcMap + | Flag_HyperlinkedSource `elem` flags = + Map.insert pkgKey defaultNameSourceUrl srcMap + | otherwise = srcMap + -- TODO: Get these from the interface files as with srcMap srcLMap' = maybe Map.empty (\path -> Map.singleton pkgKey path) srcLEntity sourceUrls' = (srcBase, srcModule', srcMap', srcLMap') diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs index 2ed4dbdd..6c66e0c6 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs @@ -1,10 +1,10 @@ module Haddock.Backends.Hyperlinker (ppHyperlinkedSource) where import Haddock.Types -import Haddock.Utils import Haddock.Backends.Xhtml.Types import Haddock.Backends.Xhtml.Utils import Haddock.Backends.Hyperlinker.Renderer +import Haddock.Backends.Hyperlinker.Utils import Text.XHtml hiding (()) @@ -29,7 +29,8 @@ ppHyperlinkedSource outdir libdir mstyle urls ifaces = do ppHyperlinkedModuleSource :: FilePath -> SourceURLs -> Interface -> IO () ppHyperlinkedModuleSource outdir urls iface = case ifaceTokenizedSrc iface of - Just tokens -> writeFile path $ showHtml . render mCssFile mJsFile $ tokens + Just tokens -> + writeFile path $ showHtml . render mCssFile mJsFile urls $ tokens Nothing -> return () where mCssFile = Just $ srcCssFile @@ -49,6 +50,3 @@ highlightScript = "highlight.js" defaultCssFile :: FilePath -> FilePath defaultCssFile libdir = libdir "html" "solarized.css" - -srcModUrl :: SourceURLs -> String -srcModUrl (_, mModSrcUrl, _, _) = fromMaybe defaultModuleSourceUrl mModSrcUrl diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs index 6d6d2012..2df62938 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs @@ -2,12 +2,16 @@ module Haddock.Backends.Hyperlinker.Renderer (render) where import Haddock.Backends.Hyperlinker.Parser import Haddock.Backends.Hyperlinker.Ast +import Haddock.Backends.Hyperlinker.Utils +import Haddock.Backends.Xhtml.Types +import Haddock.Backends.Xhtml.Utils import qualified GHC import qualified Name as GHC import qualified Unique as GHC import Data.List +import qualified Data.Map as Map import Data.Maybe import Data.Monoid @@ -16,11 +20,11 @@ import qualified Text.XHtml as Html type StyleClass = String -render :: Maybe FilePath -> Maybe FilePath -> [RichToken] -> Html -render mcss mjs tokens = header mcss mjs <> body tokens +render :: Maybe FilePath -> Maybe FilePath -> SourceURLs -> [RichToken] -> Html +render mcss mjs urls tokens = header mcss mjs <> body urls tokens -body :: [RichToken] -> Html -body = Html.body . Html.pre . mconcat . map richToken +body :: SourceURLs -> [RichToken] -> Html +body urls = Html.body . Html.pre . mconcat . map (richToken urls) header :: Maybe FilePath -> Maybe FilePath -> Html header mcss mjs @@ -40,13 +44,13 @@ header mcss mjs = , Html.src jsFile ] -richToken :: RichToken -> Html -richToken (RichToken tok Nothing) = +richToken :: SourceURLs -> RichToken -> Html +richToken _ (RichToken tok Nothing) = tokenSpan tok ! attrs where attrs = [ multiclass . tokenStyle . tkType $ tok ] -richToken (RichToken tok (Just det)) = - externalAnchor det . internalAnchor det . hyperlink det $ content +richToken urls (RichToken tok (Just det)) = + externalAnchor det . internalAnchor det . hyperlink urls det $ content where content = tokenSpan tok ! [ multiclass style] style = (tokenStyle . tkType) tok ++ richTokenStyle det @@ -93,26 +97,32 @@ externalAnchorIdent = GHC.occNameString . GHC.nameOccName internalAnchorIdent :: GHC.Name -> String internalAnchorIdent = ("local-" ++) . show . GHC.getKey . GHC.nameUnique -hyperlink :: TokenDetails -> Html -> Html -hyperlink details = case rtkName details of +hyperlink :: SourceURLs -> TokenDetails -> Html -> Html +hyperlink urls details = case rtkName details of Left name -> if GHC.isInternalName name then internalHyperlink name - else externalHyperlink mname (Just name) - where - mname = GHC.moduleName <$> GHC.nameModule_maybe name - Right name -> externalHyperlink (Just name) Nothing + else externalNameHyperlink urls name + Right name -> externalModHyperlink name internalHyperlink :: GHC.Name -> Html -> Html internalHyperlink name content = Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ] -externalHyperlink :: Maybe GHC.ModuleName -> Maybe GHC.Name -> Html -> Html -externalHyperlink mmname miname content = - Html.anchor content ! [ Html.href $ path ++ anchor ] +externalNameHyperlink :: SourceURLs -> GHC.Name -> Html -> Html +externalNameHyperlink urls name = + case Map.lookup key $ srcNameUrlMap urls of + Just url -> externalNameHyperlink' url name + Nothing -> id where - path = fromMaybe "" $ modulePath <$> mmname - anchor = fromMaybe "" $ ("#" ++) . externalAnchorIdent <$> miname + key = GHC.modulePackageKey . GHC.nameModule $ name -modulePath :: GHC.ModuleName -> String -modulePath name = GHC.moduleNameString name ++ ".html" +externalNameHyperlink' :: String -> GHC.Name -> Html -> Html +externalNameHyperlink' url name content = + Html.anchor content ! [ Html.href $ href ] + where + mdl = GHC.nameModule name + href = spliceURL Nothing (Just mdl) (Just name) Nothing url + +externalModHyperlink :: GHC.ModuleName -> Html -> Html +externalModHyperlink _ = id -- TODO diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index 78c78aca..047d9fd0 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -29,7 +29,7 @@ module Haddock.Utils ( moduleNameUrl, moduleNameUrl', moduleUrl, nameAnchorId, makeAnchorId, - defaultModuleSourceUrl, + defaultModuleSourceUrl, defaultNameSourceUrl, -- * Miscellaneous utilities getProgramName, bye, die, dieMsg, noDieMsg, mapSnd, mapMaybeM, escapeStr, @@ -281,6 +281,9 @@ makeAnchorId (f:r) = escape isAlpha f ++ concatMap (escape isLegal) r defaultModuleSourceUrl :: String defaultModuleSourceUrl = "src/%{MODULE}.html" +defaultNameSourceUrl :: String +defaultNameSourceUrl = defaultModuleSourceUrl ++ "#%{NAME}" + ------------------------------------------------------------------------------- -- * Files we need to copy from our $libdir -- cgit v1.2.3