[commit: haddock] master: Make external hyperlinks point to locations specified by source URLs. (d58bcf2)
git at git.haskell.org
git at git.haskell.org
Wed Jul 8 08:41:10 UTC 2015
Repository : ssh://git@git.haskell.org/haddock
On branch : master
Link : http://git.haskell.org/haddock.git/commitdiff/d58bcf24dfa4333e7893935eb86c036be28125b1
>---------------------------------------------------------------
commit d58bcf24dfa4333e7893935eb86c036be28125b1
Author: Łukasz Hanuszczak <lukasz.hanuszczak at gmail.com>
Date: Fri Jun 26 22:41:07 2015 +0200
Make external hyperlinks point to locations specified by source URLs.
>---------------------------------------------------------------
d58bcf24dfa4333e7893935eb86c036be28125b1
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 01e4cd4..3105edf 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 2ed4dbd..6c66e0c 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 6d6d201..2df6293 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 78c78ac..047d9fd 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
More information about the ghc-commits
mailing list