Merge pull request #1516 from duog/9-4-backport-fix-hyperlinks

Backport 9-4: Fix hyperlinks to external items and modules (#1482)

1 files changed, 13 insertions, 4 deletions

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
index 12f37ced..d77990d1 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs
@@ -24,6 +24,7 @@ import System.FilePath.Posix ((</>))
 
 import qualified Data.Map as Map
 import qualified Data.Set as Set
+import qualified Data.List as List
 
 import Text.XHtml (Html, HtmlAttr, (!))
 import qualified Text.XHtml as Html
@@ -249,14 +250,20 @@ hyperlink (srcs, srcs') ident = case ident of
     Left name -> externalModHyperlink name
 
   where
+    -- In a Nix environment, we have file:// URLs with absolute paths
+    makeHyperlinkUrl url | List.isPrefixOf "file://" url = url
+    makeHyperlinkUrl url = ".." </> url
+
     internalHyperlink name content =
         Html.anchor content ! [ Html.href $ "#" ++ internalAnchorIdent name ]
 
     externalNameHyperlink name content = case Map.lookup mdl srcs of
         Just SrcLocal -> Html.anchor content !
             [ Html.href $ hypSrcModuleNameUrl mdl name ]
-        Just (SrcExternal path) -> Html.anchor content !
-            [ Html.href $ spliceURL Nothing (Just mdl) (Just name) Nothing (".." </> path) ]
+        Just (SrcExternal path) ->
+          let hyperlinkUrl = makeHyperlinkUrl path </> hypSrcModuleNameUrl mdl name
+           in Html.anchor content !
+                [ Html.href $ spliceURL Nothing (Just mdl) (Just name) Nothing hyperlinkUrl ]
         Nothing -> content
       where
         mdl = nameModule name
@@ -265,8 +272,10 @@ hyperlink (srcs, srcs') ident = case ident of
         case Map.lookup moduleName srcs' of
           Just SrcLocal -> Html.anchor content !
             [ Html.href $ hypSrcModuleUrl' moduleName ]
-          Just (SrcExternal path) -> Html.anchor content !
-            [ Html.href $ spliceURL' Nothing (Just moduleName) Nothing Nothing (".." </> path) ]
+          Just (SrcExternal path) ->
+            let hyperlinkUrl = makeHyperlinkUrl path </> hypSrcModuleUrl' moduleName
+             in Html.anchor content !
+                  [ Html.href $ spliceURL' Nothing (Just moduleName) Nothing Nothing hyperlinkUrl ]
           Nothing -> content