Allow doc comments to link to out-of-scope things (#78).

(A bug that should have been fixed long ago.)

5 files changed, 95 insertions, 80 deletions

diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs
index ed8d4665..6e3e306a 100644
--- a/src/Haddock/Backends/Hoogle.hs
+++ b/src/Haddock/Backends/Hoogle.hs
@@ -228,22 +228,23 @@ str a = [Str a]
 
 markupTag :: Outputable o => DocMarkup o [Tag]
 markupTag = Markup {
-  markupParagraph     = box TagP,
-  markupEmpty         = str "",
-  markupString        = str,
-  markupAppend        = (++),
-  markupIdentifier    = box (TagInline "a") . str . out,
-  markupModule        = box (TagInline "a") . str,
-  markupEmphasis      = box (TagInline "i"),
-  markupMonospaced    = box (TagInline "tt"),
-  markupPic           = const $ str " ",
-  markupUnorderedList = box (TagL 'u'),
-  markupOrderedList   = box (TagL 'o'),
-  markupDefList       = box (TagL 'u') . map (\(a,b) -> TagInline "i" a : Str " " : b),
-  markupCodeBlock     = box TagPre,
-  markupURL           = box (TagInline "a") . str,
-  markupAName         = const $ str "",
-  markupExample       = box TagPre . str . unlines . map exampleToString
+  markupParagraph            = box TagP,
+  markupEmpty                = str "",
+  markupString               = str,
+  markupAppend               = (++),
+  markupIdentifier           = box (TagInline "a") . str . out,
+  markupIdentifierUnchecked  = box (TagInline "a") . str . out . snd,
+  markupModule               = box (TagInline "a") . str,
+  markupEmphasis             = box (TagInline "i"),
+  markupMonospaced           = box (TagInline "tt"),
+  markupPic                  = const $ str " ",
+  markupUnorderedList        = box (TagL 'u'),
+  markupOrderedList          = box (TagL 'o'),
+  markupDefList              = box (TagL 'u') . map (\(a,b) -> TagInline "i" a : Str " " : b),
+  markupCodeBlock            = box TagPre,
+  markupURL                  = box (TagInline "a") . str,
+  markupAName                = const $ str "",
+  markupExample              = box TagPre . str . unlines . map exampleToString
   }
 
 
diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs
index fc313888..e0a530be 100644
--- a/src/Haddock/Backends/LaTeX.hs
+++ b/src/Haddock/Backends/LaTeX.hs
@@ -999,34 +999,35 @@ latexMonoMunge c   s = latexMunge c s
 
 parLatexMarkup :: (a -> LaTeX) -> DocMarkup a (StringContext -> LaTeX)
 parLatexMarkup ppId = Markup {
-  markupParagraph     = \p v -> p v <> text "\\par" $$ text "",
-  markupEmpty         = \_ -> empty,
-  markupString        = \s v -> text (fixString v s),
-  markupAppend        = \l r v -> l v <> r v,
-  markupIdentifier    = markupId,
-  markupModule        = \m _ -> let (mdl,_ref) = break (=='#') m in tt (text mdl),
-  markupEmphasis      = \p v -> emph (p v),
-  markupMonospaced    = \p _ -> tt (p Mono),
-  markupUnorderedList = \p v -> itemizedList (map ($v) p) $$ text "",
-  markupPic           = \path _ -> parens (text "image: " <> text path),
-  markupOrderedList   = \p v -> enumeratedList (map ($v) p) $$ text "",
-  markupDefList       = \l v -> descriptionList (map (\(a,b) -> (a v, b v)) l),
-  markupCodeBlock     = \p _ -> quote (verb (p Verb)) $$ text "",
-  markupURL           = \u _ -> text "\\url" <> braces (text u),
-  markupAName         = \_ _ -> empty,
-  markupExample       = \e _ -> quote $ verb $ text $ unlines $ map exampleToString e
+  markupParagraph            = \p v -> p v <> text "\\par" $$ text "",
+  markupEmpty                = \_ -> empty,
+  markupString               = \s v -> text (fixString v s),
+  markupAppend               = \l r v -> l v <> r v,
+  markupIdentifier           = markupId ppId,
+  markupIdentifierUnchecked  = markupId (ppVerbOccName . snd),
+  markupModule               = \m _ -> let (mdl,_ref) = break (=='#') m in tt (text mdl),
+  markupEmphasis             = \p v -> emph (p v),
+  markupMonospaced           = \p _ -> tt (p Mono),
+  markupUnorderedList        = \p v -> itemizedList (map ($v) p) $$ text "",
+  markupPic                  = \path _ -> parens (text "image: " <> text path),
+  markupOrderedList          = \p v -> enumeratedList (map ($v) p) $$ text "",
+  markupDefList              = \l v -> descriptionList (map (\(a,b) -> (a v, b v)) l),
+  markupCodeBlock            = \p _ -> quote (verb (p Verb)) $$ text "",
+  markupURL                  = \u _ -> text "\\url" <> braces (text u),
+  markupAName                = \_ _ -> empty,
+  markupExample              = \e _ -> quote $ verb $ text $ unlines $ map exampleToString e
   }
   where
     fixString Plain s = latexFilter s
     fixString Verb  s = s
     fixString Mono  s = latexMonoFilter s
 
-    markupId id v =
+    markupId ppId_ id v =
       case v of
         Verb  -> theid
         Mono  -> theid
         Plain -> text "\\haddockid" <> braces theid
-      where theid = ppId id
+      where theid = ppId_ id
 
 
 latexMarkup :: DocMarkup DocName (StringContext -> LaTeX)
diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs
index 9ac4211a..52bde5b6 100644
--- a/src/Haddock/Backends/Xhtml.hs
+++ b/src/Haddock/Backends/Xhtml.hs
@@ -83,8 +83,7 @@ ppHtml doctitle maybe_package ifaces odir prologue
         themes maybe_index_url maybe_source_url maybe_wiki_url
         (map toInstalledIface visible_ifaces)
         False -- we don't want to display the packages in a single-package contents
-        prologue
-        debug
+        prologue debug qual
 
   when (isNothing maybe_index_url) $
     ppHtmlIndex odir doctitle maybe_package
@@ -224,10 +223,11 @@ ppHtmlContents
    -> WikiURLs
    -> [InstalledInterface] -> Bool -> Maybe (Doc GHC.RdrName)
    -> Bool
+   -> Qualification  -- ^ How to qualify names
    -> IO ()
 ppHtmlContents odir doctitle _maybe_package
   themes maybe_index_url
-  maybe_source_url maybe_wiki_url ifaces showPkgs prologue debug = do
+  maybe_source_url maybe_wiki_url ifaces showPkgs prologue debug qual = do
   let tree = mkModuleTree showPkgs
          [(instMod iface, toInstalledDescription iface) | iface <- ifaces]
       html =
@@ -235,8 +235,8 @@ ppHtmlContents odir doctitle _maybe_package
         bodyHtml doctitle Nothing
           maybe_source_url maybe_wiki_url
           Nothing maybe_index_url << [
-            ppPrologue doctitle prologue,
-            ppModuleTree tree
+            ppPrologue qual doctitle prologue,
+            ppModuleTree qual tree
           ]
   createDirectoryIfMissing True odir
   writeFile (joinPath [odir, contentsHtmlFile]) (renderToString debug html)
@@ -245,27 +245,27 @@ ppHtmlContents odir doctitle _maybe_package
   ppHtmlContentsFrame odir doctitle themes ifaces debug
 
 
-ppPrologue :: String -> Maybe (Doc GHC.RdrName) -> Html
-ppPrologue _ Nothing = noHtml
-ppPrologue title (Just doc) =
-  divDescription << (h1 << title +++ docElement thediv (rdrDocToHtml doc))
+ppPrologue :: Qualification -> String -> Maybe (Doc GHC.RdrName) -> Html
+ppPrologue _ _ Nothing = noHtml
+ppPrologue qual title (Just doc) =
+  divDescription << (h1 << title +++ docElement thediv (rdrDocToHtml qual doc))
 
 
-ppModuleTree :: [ModuleTree] -> Html
-ppModuleTree ts =
-  divModuleList << (sectionName << "Modules" +++ mkNodeList [] "n" ts)
+ppModuleTree :: Qualification -> [ModuleTree] -> Html
+ppModuleTree qual ts =
+  divModuleList << (sectionName << "Modules" +++ mkNodeList qual [] "n" ts)
 
 
-mkNodeList :: [String] -> String -> [ModuleTree] -> Html
-mkNodeList ss p ts = case ts of
+mkNodeList :: Qualification -> [String] -> String -> [ModuleTree] -> Html
+mkNodeList qual ss p ts = case ts of
   [] -> noHtml
-  _ -> unordList (zipWith (mkNode ss) ps ts)
+  _ -> unordList (zipWith (mkNode qual ss) ps ts)
   where
     ps = [ p ++ '.' : show i | i <- [(1::Int)..]]
 
 
-mkNode :: [String] -> String -> ModuleTree -> Html
-mkNode ss p (Node s leaf pkg short ts) =
+mkNode :: Qualification -> [String] -> String -> ModuleTree -> Html
+mkNode qual ss p (Node s leaf pkg short ts) =
   htmlModule +++ shortDescr +++ htmlPkg +++ subtree
   where
     modAttrs = case (ts, leaf) of
@@ -288,10 +288,10 @@ mkNode ss p (Node s leaf pkg short ts) =
 
     mdl = intercalate "." (reverse (s:ss))
 
-    shortDescr = maybe noHtml origDocToHtml short
+    shortDescr = maybe noHtml (origDocToHtml qual) short
     htmlPkg = maybe noHtml (thespan ! [theclass "package"] <<) pkg
 
-    subtree = mkNodeList (s:ss) p ts ! collapseSection p True ""
+    subtree = mkNodeList qual (s:ss) p ts ! collapseSection p True ""
 
 
 -- | Turn a module tree into a flat list of full module names.  E.g.,
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)