aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--haddock-api/src/Haddock.hs2
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker.hs25
-rw-r--r--haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs42
3 files changed, 40 insertions, 29 deletions
diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index d596c075..caaa1eef 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -321,7 +321,7 @@ render dflags flags qual ifaces installedIfaces srcMap = do
libDir
when (Flag_HyperlinkedSource `elem` flags) $ do
- ppHyperlinkedSource odir libDir opt_source_css visibleIfaces
+ ppHyperlinkedSource odir libDir opt_source_css pkgKey srcMap visibleIfaces
-- | From GHC 7.10, this function has a potential to crash with a
-- nasty message such as @expectJust getPackageDetails@ because
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
index f197eaa3..f2caa2c1 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs
@@ -8,33 +8,34 @@ import Haddock.Backends.Hyperlinker.Renderer
import Haddock.Backends.Hyperlinker.Utils
import Text.XHtml hiding ((</>))
+import GHC
import Data.Maybe
import System.Directory
import System.FilePath
-ppHyperlinkedSource :: FilePath -> FilePath
- -> Maybe FilePath
- -> [Interface]
+ppHyperlinkedSource :: FilePath -> FilePath -> Maybe FilePath
+ -> PackageKey -> SrcMap -> [Interface]
-> IO ()
-ppHyperlinkedSource outdir libdir mstyle ifaces = do
+ppHyperlinkedSource outdir libdir mstyle pkg srcs ifaces = do
createDirectoryIfMissing True srcdir
let cssFile = fromMaybe (defaultCssFile libdir) mstyle
copyFile cssFile $ srcdir </> srcCssFile
copyFile (libdir </> "html" </> highlightScript) $
srcdir </> highlightScript
- mapM_ (ppHyperlinkedModuleSource srcdir) ifaces
+ mapM_ (ppHyperlinkedModuleSource srcdir pkg srcs) ifaces
where
srcdir = outdir </> hypSrcDir
-ppHyperlinkedModuleSource :: FilePath -> Interface -> IO ()
-ppHyperlinkedModuleSource srcdir iface = case ifaceTokenizedSrc iface of
- Just tokens ->
- writeFile path $ showHtml . render mCssFile mJsFile $ tokens
- Nothing -> return ()
+ppHyperlinkedModuleSource :: FilePath
+ -> PackageKey -> SrcMap -> Interface
+ -> IO ()
+ppHyperlinkedModuleSource srcdir pkg srcs iface =
+ case ifaceTokenizedSrc iface of
+ Just tokens -> writeFile path . showHtml . render' $ tokens
+ Nothing -> return ()
where
- mCssFile = Just $ srcCssFile
- mJsFile = Just $ highlightScript
+ render' = render (Just srcCssFile) (Just highlightScript) pkg srcs
path = srcdir </> hypSrcModuleFile (ifaceMod iface)
srcCssFile :: FilePath
diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
index d8ea5ec7..b05a5b8a 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -1,5 +1,6 @@
module Haddock.Backends.Hyperlinker.Renderer (render) where
+import Haddock.Types
import Haddock.Backends.Hyperlinker.Parser
import Haddock.Backends.Hyperlinker.Ast
import Haddock.Backends.Hyperlinker.Utils
@@ -8,20 +9,25 @@ import qualified GHC
import qualified Name as GHC
import qualified Unique as GHC
+import System.FilePath.Posix ((</>))
+
import Data.List
import Data.Maybe
import Data.Monoid
+import qualified Data.Map as Map
import Text.XHtml (Html, HtmlAttr, (!))
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
+ -> GHC.PackageKey -> SrcMap -> [RichToken]
+ -> Html
+render mcss mjs pkg srcs tokens = header mcss mjs <> body pkg srcs tokens
-body :: [RichToken] -> Html
-body = Html.body . Html.pre . mconcat . map richToken
+body :: GHC.PackageKey -> SrcMap -> [RichToken] -> Html
+body pkg srcs = Html.body . Html.pre . mconcat . map (richToken pkg srcs)
header :: Maybe FilePath -> Maybe FilePath -> Html
header mcss mjs
@@ -41,13 +47,13 @@ header mcss mjs =
, Html.src scriptFile
]
-richToken :: RichToken -> Html
-richToken (RichToken tok Nothing) =
+richToken :: GHC.PackageKey -> SrcMap -> 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 pkg srcs (RichToken tok (Just det)) =
+ externalAnchor det . internalAnchor det . hyperlink pkg srcs det $ content
where
content = tokenSpan tok ! [ multiclass style]
style = (tokenStyle . tkType) tok ++ richTokenStyle det
@@ -94,25 +100,29 @@ externalAnchorIdent = hypSrcNameUrl
internalAnchorIdent :: GHC.Name -> String
internalAnchorIdent = ("local-" ++) . show . GHC.getKey . GHC.nameUnique
-hyperlink :: TokenDetails -> Html -> Html
-hyperlink details = case rtkName details of
+hyperlink :: GHC.PackageKey -> SrcMap -> TokenDetails -> Html -> Html
+hyperlink pkg srcs details = case rtkName details of
Left name ->
if GHC.isInternalName name
then internalHyperlink name
- else externalNameHyperlink name
+ else externalNameHyperlink pkg srcs name
Right name -> externalModHyperlink name
internalHyperlink :: GHC.Name -> Html -> Html
internalHyperlink name content =
Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ]
-externalNameHyperlink :: GHC.Name -> Html -> Html
-externalNameHyperlink name content =
- Html.anchor content ! [ Html.href href ]
+externalNameHyperlink :: GHC.PackageKey -> SrcMap -> GHC.Name -> Html -> Html
+externalNameHyperlink pkg srcs name content
+ | namePkg == pkg = Html.anchor content !
+ [ Html.href $ hypSrcModuleNameUrl mdl name ]
+ | Just path <- Map.lookup namePkg srcs = Html.anchor content !
+ [ Html.href $ path </> hypSrcModuleNameUrl mdl name ]
+ | otherwise = content
where
- href = hypSrcModuleNameUrl (GHC.nameModule name) name
+ mdl = GHC.nameModule name
+ namePkg = GHC.modulePackageKey mdl
externalModHyperlink :: GHC.ModuleName -> Html -> Html
externalModHyperlink mdl content =
Html.anchor content ! [ Html.href $ hypSrcModuleUrl' mdl ]
-
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 05:40:10 +0000