From 1345132fd141b8d9b12e858ccc0765272f703e49 Mon Sep 17 00:00:00 2001
From: David Waern <david.waern@gmail.com>
Date: Sat, 26 Nov 2011 17:01:06 +0100
Subject: Allow doc comments to link to out-of-scope things (#78).

(A bug that should have been fixed long ago.)
---
 src/Haddock/Backends/Xhtml/DocMarkup.hs | 53 +++++++++++++++++----------------
 src/Haddock/Backends/Xhtml/Names.hs     | 14 ++++++++-
 2 files changed, 40 insertions(+), 27 deletions(-)

(limited to 'src/Haddock/Backends/Xhtml')

diff --git a/src/Haddock/Backends/Xhtml/DocMarkup.hs b/src/Haddock/Backends/Xhtml/DocMarkup.hs
index 05ce7dbb..87d67b76 100644
--- a/src/Haddock/Backends/Xhtml/DocMarkup.hs
+++ b/src/Haddock/Backends/Xhtml/DocMarkup.hs
@@ -30,25 +30,26 @@ import Text.XHtml hiding ( name, title, p, quote )
 import GHC
 
 
-parHtmlMarkup :: (a -> Html) -> DocMarkup a Html
-parHtmlMarkup ppId = Markup {
-  markupEmpty         = noHtml,
-  markupString        = toHtml,
-  markupParagraph     = paragraph,
-  markupAppend        = (+++),
-  markupIdentifier    = thecode . ppId,
-  markupModule        = \m -> let (mdl,ref) = break (=='#') m
-                              in ppModuleRef (mkModuleNoPackage mdl) ref,
-  markupEmphasis      = emphasize,
-  markupMonospaced    = thecode,
-  markupUnorderedList = unordList,
-  markupOrderedList   = ordList,
-  markupDefList       = defList,
-  markupCodeBlock     = pre,
-  markupURL           = \url -> anchor ! [href url] << url,
-  markupAName         = \aname -> namedAnchor aname << "",
-  markupPic           = \path -> image ! [src path],
-  markupExample       = examplesToHtml
+parHtmlMarkup :: Qualification -> (a -> Html) -> DocMarkup a Html
+parHtmlMarkup qual ppId = Markup {
+  markupEmpty                = noHtml,
+  markupString               = toHtml,
+  markupParagraph            = paragraph,
+  markupAppend               = (+++),
+  markupIdentifier           = thecode . ppId,
+  markupIdentifierUnchecked  = thecode . ppUncheckedLink qual,
+  markupModule               = \m -> let (mdl,ref) = break (=='#') m
+                                     in ppModuleRef (mkModuleNoPackage mdl) ref,
+  markupEmphasis             = emphasize,
+  markupMonospaced           = thecode,
+  markupUnorderedList        = unordList,
+  markupOrderedList          = ordList,
+  markupDefList              = defList,
+  markupCodeBlock            = pre,
+  markupURL                  = \url -> anchor ! [href url] << url,
+  markupAName                = \aname -> namedAnchor aname << "",
+  markupPic                  = \path -> image ! [src path],
+  markupExample              = examplesToHtml
   }
   where
     examplesToHtml l = pre (concatHtml $ map exampleToHtml l) ! [theclass "screen"]
@@ -64,17 +65,17 @@ parHtmlMarkup ppId = Markup {
 -- ugly extra whitespace with some browsers).  FIXME: Does this still apply?
 docToHtml :: Qualification -> Doc DocName -> Html
 docToHtml qual = markup fmt . cleanup
-  where fmt = parHtmlMarkup (ppDocName qual)
+  where fmt = parHtmlMarkup qual (ppDocName qual)
 
 
-origDocToHtml :: Doc Name -> Html
-origDocToHtml = markup fmt . cleanup
-  where fmt = parHtmlMarkup ppName
+origDocToHtml :: Qualification -> Doc Name -> Html
+origDocToHtml qual = markup fmt . cleanup
+  where fmt = parHtmlMarkup qual ppName
 
 
-rdrDocToHtml :: Doc RdrName -> Html
-rdrDocToHtml = markup fmt . cleanup
-  where fmt = parHtmlMarkup ppRdrName
+rdrDocToHtml :: Qualification -> Doc RdrName -> Html
+rdrDocToHtml qual = markup fmt . cleanup
+  where fmt = parHtmlMarkup qual ppRdrName
 
 
 docElement :: (Html -> Html) -> Html -> Html
diff --git a/src/Haddock/Backends/Xhtml/Names.hs b/src/Haddock/Backends/Xhtml/Names.hs
index c5166d7f..19efea2e 100644
--- a/src/Haddock/Backends/Xhtml/Names.hs
+++ b/src/Haddock/Backends/Xhtml/Names.hs
@@ -11,7 +11,7 @@
 -- Portability :  portable
 -----------------------------------------------------------------------------
 module Haddock.Backends.Xhtml.Names (
-  ppName, ppDocName, ppLDocName, ppRdrName,
+  ppName, ppDocName, ppLDocName, ppRdrName, ppUncheckedLink,
   ppBinder, ppBinder',
   ppModule, ppModuleRef,
   linkId
@@ -39,6 +39,10 @@ ppRdrName :: RdrName -> Html
 ppRdrName = ppOccName . rdrNameOcc
 
 
+ppUncheckedLink :: Qualification -> (ModuleName, OccName) -> Html
+ppUncheckedLink _ (mdl, occ) = linkIdOcc' mdl (Just occ) << ppOccName occ -- TODO: apply ppQualifyName
+
+
 ppLDocName :: Qualification -> Located DocName -> Html
 ppLDocName qual (L _ d) = ppDocName qual d
 
@@ -110,6 +114,14 @@ linkIdOcc mdl mbName = anchor ! [href url]
       Just name -> moduleNameUrl mdl name
 
 
+linkIdOcc' :: ModuleName -> Maybe OccName -> Html -> Html
+linkIdOcc' mdl mbName = anchor ! [href url]
+  where
+    url = case mbName of
+      Nothing   -> moduleHtmlFile' mdl
+      Just name -> moduleNameUrl' mdl name
+
+
 ppModule :: Module -> Html
 ppModule mdl = anchor ! [href (moduleUrl mdl)]
                << toHtml (moduleString mdl)
-- 
cgit v1.2.3