Add an optional wiki link for each top level exported name.

In each module, for each "top level" exported entity we add a hyper link to a
corresponding wiki page. The link url gets the name of the exported entity as
a '#'-style anchor, so if there is an anchor in the page with that name then
the users browser should jump directly to it. By "top level" we mean functions,
classes, class members and data types (data, type, newtype), but not data
constructors, class instances or data type class membership.

The link is added at the right of the page and in a small font. Hopefully this
is the right balance of visibility/distraction.

We also include a link to the wiki base url in the contents and index pages.

2 files changed, 105 insertions, 75 deletions

diff --git a/src/HaddockHtml.hs b/src/HaddockHtml.hs
index 4c98bc51..420eab26 100644
--- a/src/HaddockHtml.hs
+++ b/src/HaddockHtml.hs
@@ -30,7 +30,7 @@ import Control.Exception ( bracket )
 import Control.Monad ( when, unless )
 import Data.Char ( isUpper, toUpper )
 import Data.List ( sortBy )
-import Data.Maybe ( fromJust, isJust, mapMaybe )
+import Data.Maybe ( fromJust, isJust, mapMaybe, maybeToList )
 import Foreign.Marshal.Alloc ( allocaBytes )
 import System.IO ( IOMode(..), hClose, hGetBuf, hPutBuf )
 
@@ -57,13 +57,15 @@ ppHtml doctitle maybe_package ifaces odir prologue maybe_html_help_format
 	visible i = OptHide `notElem` iface_options i
 
   when (not (isJust maybe_contents_url)) $ 
-    ppHtmlContents odir doctitle maybe_package maybe_html_help_format maybe_index_url 
+    ppHtmlContents odir doctitle maybe_package
+        maybe_html_help_format maybe_index_url maybe_wiki_url
 	[ iface{iface_package=Nothing} | iface <- visible_ifaces ]
 	-- we don't want to display the packages in a single-package contents
 	prologue
 
   when (not (isJust maybe_index_url)) $ 
-    ppHtmlIndex odir doctitle maybe_package maybe_html_help_format maybe_contents_url visible_ifaces
+    ppHtmlIndex odir doctitle maybe_package
+        maybe_html_help_format maybe_contents_url maybe_wiki_url visible_ifaces
     
   when (not (isJust maybe_contents_url && isJust maybe_index_url)) $ 
 	ppHtmlHelpFiles doctitle maybe_package ifaces odir maybe_html_help_format []
@@ -133,8 +135,8 @@ footer =
 	)
    
 
-srcButton :: Maybe String -> String -> Interface -> HtmlTable
-srcButton maybe_source_url _ iface
+srcButton :: Maybe String -> Interface -> HtmlTable
+srcButton maybe_source_url iface
   | Just u <- maybe_source_url =
 	let src_url = spliceSrcURL iface u
 	in
@@ -152,12 +154,11 @@ spliceSrcURL iface url = run url
 	modl_str = case iface_module iface of { Module m -> 
 		   map (\x -> if x == '.' then '/' else x) m }
 
-wikiButton :: Maybe String -> Interface -> HtmlTable
+wikiButton :: Maybe String -> Maybe String -> HtmlTable
 wikiButton Nothing _ = Html.emptyTable
-wikiButton (Just wiki_base_url) iface
-  = topButBox (anchor ! [href url] << toHtml "Wiki")
-  where url = pathJoin [wiki_base_url, mod]
-	Module mod = iface_module iface
+wikiButton (Just wiki_base_url) maybe_mod
+  = topButBox (anchor ! [href url] << toHtml "User Comments")
+  where url = pathJoin (wiki_base_url : maybeToList maybe_mod)
 
 contentsButton :: Maybe String -> HtmlTable
 contentsButton maybe_contents_url 
@@ -173,14 +174,16 @@ indexButton maybe_index_url
 			Nothing -> indexHtmlFile
 			Just url -> url
 
-simpleHeader :: String -> Maybe String -> Maybe String -> HtmlTable
-simpleHeader doctitle maybe_contents_url maybe_index_url = 
+simpleHeader :: String -> Maybe String -> Maybe String
+             -> Maybe String -> HtmlTable
+simpleHeader doctitle maybe_contents_url maybe_index_url maybe_wiki_url = 
   (tda [theclass "topbar"] << 
      vanillaTable << (
        (td << 
   	image ! [src "haskell_icon.gif", width "16", height 16, alt " " ]
        ) <->
        (tda [theclass "title"] << toHtml doctitle) <->
+	wikiButton maybe_wiki_url Nothing <->
 	contentsButton maybe_contents_url <-> indexButton maybe_index_url
    ))
 
@@ -196,8 +199,8 @@ pageHeader mdl iface doctitle
   	image ! [src "haskell_icon.gif", width "16", height 16, alt " "]
        ) <->
        (tda [theclass "title"] << toHtml doctitle) <->
-	srcButton maybe_source_url mdl iface <->
-	wikiButton maybe_wiki_url iface <->
+	srcButton maybe_source_url iface <->
+	wikiButton maybe_wiki_url (Just mdl) <->
 	contentsButton maybe_contents_url <->
 	indexButton maybe_index_url
     )
@@ -241,9 +244,11 @@ ppHtmlContents
    -> Maybe String
    -> Maybe String
    -> Maybe String
+   -> Maybe String
    -> [Interface] -> Maybe Doc
    -> IO ()
-ppHtmlContents odir doctitle maybe_package maybe_html_help_format maybe_index_url
+ppHtmlContents odir doctitle
+  maybe_package maybe_html_help_format maybe_index_url maybe_wiki_url
   mdls prologue = do
   let tree = mkModuleTree 
          [(iface_module iface,
@@ -256,7 +261,7 @@ ppHtmlContents odir doctitle maybe_package maybe_html_help_format maybe_index_ur
 		 styleSheet +++
 		 (script ! [src jsFile, thetype "text/javascript"] $ noHtml)) +++
         body << vanillaTable << (
-   	    simpleHeader doctitle Nothing maybe_index_url </>
+   	    simpleHeader doctitle Nothing maybe_index_url maybe_wiki_url </>
 	    ppPrologue doctitle prologue </>
 	    ppModuleTree doctitle tree </>
 	    s15 </>
@@ -347,15 +352,17 @@ ppHtmlIndex :: FilePath
             -> Maybe String
             -> Maybe String
             -> Maybe String
+            -> Maybe String
             -> [Interface] 
             -> IO ()
-ppHtmlIndex odir doctitle maybe_package maybe_html_help_format maybe_contents_url ifaces = do
+ppHtmlIndex odir doctitle maybe_package maybe_html_help_format
+  maybe_contents_url maybe_wiki_url ifaces = do
   let html = 
 	header (documentCharacterEncoding +++
 		thetitle (toHtml (doctitle ++ " (Index)")) +++
 		styleSheet) +++
         body << vanillaTable << (
-	    simpleHeader doctitle maybe_contents_url Nothing </>
+	    simpleHeader doctitle maybe_contents_url Nothing maybe_wiki_url </>
 	    index_html
 	   )
 
@@ -398,7 +405,7 @@ ppHtmlIndex odir doctitle maybe_package maybe_html_help_format maybe_contents_ur
 		thetitle (toHtml (doctitle ++ " (Index)")) +++
 		styleSheet) +++
              body << vanillaTable << (
-	        simpleHeader doctitle maybe_contents_url Nothing </>
+	        simpleHeader doctitle maybe_contents_url Nothing maybe_wiki_url </>
 		indexInitialLetterLinks </>
 	        tda [theclass "section1"] << 
 	      	toHtml ("Index (" ++ c:")") </>
@@ -485,13 +492,13 @@ ppHtmlModule odir doctitle
 	    pageHeader mdl iface doctitle
 		maybe_source_url maybe_wiki_url
 		maybe_contents_url maybe_index_url </> s15 </>
-	    ifaceToHtml mdl iface </> s15 </>
+	    ifaceToHtml mdl maybe_wiki_url iface </> s15 </>
 	    footer
          )
   writeFile (pathJoin [odir, moduleHtmlFile mdl]) (renderHtml html)
 
-ifaceToHtml :: String -> Interface -> HtmlTable
-ifaceToHtml _ iface 
+ifaceToHtml :: String -> Maybe String -> Interface -> HtmlTable
+ifaceToHtml _ maybe_wiki_url iface 
   = abovesSep s15 (contents: description: synopsis: maybe_doc_hdr: bdy)
   where 
 	exports = numberSectionHeadings (iface_exports iface)
@@ -519,7 +526,7 @@ ifaceToHtml _ iface
 	  = (tda [theclass "section1"] << toHtml "Synopsis") </>
 	    s15 </>
             (tda [theclass "body"] << vanillaTable <<
-  	        abovesSep s8 (map (processExport True)
+  	        abovesSep s8 (map (processExport True Nothing)
 			(filter forSummary exports))
 	    )
 
@@ -531,7 +538,10 @@ ifaceToHtml _ iface
 		   ExportGroup _ _ _ : _ -> Html.emptyTable
 		   _ -> tda [ theclass "section1" ] << toHtml "Documentation"
 
-	bdy  = map (processExport False) exports
+	bdy  = map (processExport False wiki_info) exports
+	wiki_info = case maybe_wiki_url of
+		      Nothing -> Nothing
+		      Just wiki_url -> Just (wiki_url, iface_module iface)
 
 ppModuleContents :: [ExportItem] -> HtmlTable
 ppModuleContents exports
@@ -567,18 +577,21 @@ numberSectionHeadings exports = go 1 exports
 	go n (other:es)
 	  = other : go n es
 
-processExport :: Bool -> ExportItem -> HtmlTable
-processExport _ (ExportGroup lev id0 doc)
+-- The base URL for wiki links, and the current module
+type WikiInfo = Maybe (String, Module)
+
+processExport :: Bool -> WikiInfo -> ExportItem -> HtmlTable
+processExport _ _ (ExportGroup lev id0 doc)
   = ppDocGroup lev (namedAnchor id0 << docToHtml doc)
-processExport summary (ExportDecl x decl insts)
-  = doDecl summary x decl insts
-processExport summmary (ExportNoDecl _ y [])
+processExport summary wiki (ExportDecl x decl insts)
+  = doDecl summary wiki x decl insts
+processExport summmary _ (ExportNoDecl _ y [])
   = declBox (ppHsQName y)
-processExport summmary (ExportNoDecl _ y subs)
+processExport summmary _ (ExportNoDecl _ y subs)
   = declBox (ppHsQName y <+> parenList (map ppHsQName subs))
-processExport _ (ExportDoc doc)
+processExport _ _ (ExportDoc doc)
   = docBox (docToHtml doc)
-processExport _ (ExportModule (Module mdl))
+processExport _ _ (ExportModule (Module mdl))
   = declBox (toHtml "module" <+> ppHsModule mdl)
 
 forSummary :: ExportItem -> Bool
@@ -596,36 +609,36 @@ ppDocGroup lev doc
 -- -----------------------------------------------------------------------------
 -- Converting declarations to HTML
 
-declWithDoc :: Bool -> Maybe Doc -> Html -> HtmlTable
-declWithDoc True  _          html_decl = declBox html_decl
-declWithDoc False Nothing    html_decl = declBox html_decl
-declWithDoc False (Just doc) html_decl = 
-		declBox html_decl </> docBox (docToHtml doc)
+declWithDoc :: Bool -> WikiInfo -> HsName -> Maybe Doc -> Html -> HtmlTable
+declWithDoc True  _    _  _          html_decl = declBox html_decl
+declWithDoc False wiki nm Nothing    html_decl = topDeclBox wiki nm html_decl
+declWithDoc False wiki nm (Just doc) html_decl = 
+		topDeclBox wiki nm html_decl </> docBox (docToHtml doc)
 
-doDecl :: Bool -> HsQName -> HsDecl -> [InstHead] -> HtmlTable
-doDecl summary x d instances = do_decl d
+doDecl :: Bool -> WikiInfo -> HsQName -> HsDecl -> [InstHead] -> HtmlTable
+doDecl summary wiki x d instances = do_decl d
   where
      do_decl (HsTypeSig _ [nm] ty doc) 
-	= ppFunSig summary nm ty doc
+	= ppFunSig summary wiki nm ty doc
 
      do_decl (HsForeignImport _ _ _ _ n ty doc)
-	= ppFunSig summary n ty doc
+	= ppFunSig summary wiki n ty doc
 
      do_decl (HsTypeDecl _ nm args ty doc)
-	= declWithDoc summary doc (
+	= declWithDoc summary wiki nm doc (
 	      hsep ([keyword "type", ppHsBinder summary nm]
 		 ++ map ppHsName args) <+> equals <+> ppHsType ty)
 
      do_decl (HsNewTypeDecl loc ctx nm args con drv doc)
-	= ppHsDataDecl summary instances True{-is newtype-} x
+	= ppHsDataDecl summary wiki instances True{-is newtype-} x
 		(HsDataDecl loc ctx nm args [con] drv doc)
 	  -- print it as a single-constructor datatype
 
      do_decl d0@(HsDataDecl{})
-	= ppHsDataDecl summary instances False{-not newtype-} x d0
+	= ppHsDataDecl summary wiki instances False{-not newtype-} x d0
 
      do_decl d0@(HsClassDecl{})
-	= ppHsClassDecl summary instances x d0
+	= ppHsClassDecl summary wiki instances x d0
 
      do_decl (HsDocGroup _ lev str)
 	= if summary then Html.emptyTable 
@@ -640,31 +653,32 @@ ppTypeSig summary nm ty = ppHsBinder summary nm <+> dcolon <+> ppHsType ty
 -- -----------------------------------------------------------------------------
 -- Data & newtype declarations
 
-ppShortDataDecl :: Bool -> Bool -> HsDecl -> Html
-ppShortDataDecl summary is_newty 
+ppShortDataDecl :: Bool -> WikiInfo -> Bool -> HsDecl -> Html
+ppShortDataDecl summary _ is_newty 
 	(HsDataDecl _ _ nm args [con] _ _doc) =
    ppHsDataHeader summary is_newty nm args      
      <+> equals <+> ppShortConstr summary con
-ppShortDataDecl summary is_newty
+ppShortDataDecl summary _ is_newty
 	(HsDataDecl _ _ nm args [] _ _doc) = 
    ppHsDataHeader summary is_newty nm args
-ppShortDataDecl summary is_newty
+ppShortDataDecl summary wiki is_newty
 	(HsDataDecl _ _ nm args cons _ _doc) = 
    vanillaTable << (
-	declBox (ppHsDataHeader summary is_newty nm args) </>
+	(if summary then declBox else topDeclBox wiki nm)
+          (ppHsDataHeader summary is_newty nm args) </>
 	tda [theclass "body"] << vanillaTable << (
 	  aboves (zipWith do_constr ('=':repeat '|') cons)
         )
    )
   where do_constr c con = declBox (toHtml [c] <+> ppShortConstr summary con)
-ppShortDataDecl _ _ d =
+ppShortDataDecl _ _ _ d =
     error $ "HaddockHtml.ppShortDataDecl: unexpected decl " ++ show d
 
 -- The rest of the cases:
-ppHsDataDecl :: Ord key => Bool	-> [InstHead] -> Bool -> key -> HsDecl -> HtmlTable
-ppHsDataDecl summary instances is_newty 
+ppHsDataDecl :: Ord key => Bool	-> WikiInfo -> [InstHead] -> Bool -> key -> HsDecl -> HtmlTable
+ppHsDataDecl summary wiki instances is_newty 
      x decl@(HsDataDecl _ _ nm args cons _ doc)
-  | summary = declWithDoc summary doc (ppShortDataDecl summary is_newty decl)
+  | summary = declWithDoc summary wiki nm doc (ppShortDataDecl summary wiki is_newty decl)
 
   | otherwise
         = dataheader </> 
@@ -674,7 +688,7 @@ ppHsDataDecl summary instances is_newty
 		instances_bit
             )
   where
-	dataheader = declBox (ppHsDataHeader False is_newty nm args)
+	dataheader = topDeclBox wiki nm (ppHsDataHeader False is_newty nm args)
 
 	constr_table
 	 	| any isRecDecl cons  = spacedTable5
@@ -704,7 +718,7 @@ ppHsDataDecl summary instances is_newty
 		        )
  		   )
 
-ppHsDataDecl _ _ _ _ d =
+ppHsDataDecl _ _ _ _ _ d =
     error $ "HaddockHtml.ppHsDataDecl: unexpected decl " ++ show d
 
 isRecDecl :: HsConDecl -> Bool
@@ -821,28 +835,28 @@ ppFds fds =
 	fundep (vars1,vars2) = hsep (map ppHsName vars1) <+> toHtml "->" <+>
 			       hsep (map ppHsName vars2)
 
-ppShortClassDecl :: Bool -> HsDecl -> HtmlTable
-ppShortClassDecl summary (HsClassDecl _ ctxt nm tvs fds decls _) = 
+ppShortClassDecl :: Bool -> WikiInfo -> HsDecl -> HtmlTable
+ppShortClassDecl summary wiki (HsClassDecl _ ctxt nm tvs fds decls _) = 
   if null decls
-    then declBox hdr
-    else declBox (hdr <+> keyword "where")
+    then (if summary then declBox else topDeclBox wiki nm) hdr
+    else (if summary then declBox else topDeclBox wiki nm) (hdr <+> keyword "where")
 	    </> 
            (tda [theclass "body"] << 
 	     vanillaTable << 
-	       aboves [ ppFunSig summary n ty doc 
+	       aboves [ ppFunSig summary wiki n ty doc 
 		      | HsTypeSig _ [n] ty doc <- decls
 		      ]
           )
          
    where
 	hdr = ppClassHdr summary ctxt nm tvs fds
-ppShortClassDecl _ d =
+ppShortClassDecl _ _ d =
     error $ "HaddockHtml.ppShortClassDecl: unexpected decl: " ++ show d
 
-ppHsClassDecl :: Ord key => Bool -> [InstHead] -> key -> HsDecl -> HtmlTable
-ppHsClassDecl summary instances orig_c
+ppHsClassDecl :: Ord key => Bool -> WikiInfo -> [InstHead] -> key -> HsDecl -> HtmlTable
+ppHsClassDecl summary wiki instances orig_c
 	decl@(HsClassDecl _ ctxt nm tvs fds decls doc)
-  | summary = ppShortClassDecl summary decl
+  | summary = ppShortClassDecl summary wiki decl
 
   | otherwise
         = classheader </>
@@ -852,8 +866,8 @@ ppHsClassDecl summary instances orig_c
 
    where 
 	classheader
-	   | null decls = declBox hdr
-	   | otherwise  = declBox (hdr <+> keyword "where")
+	   | null decls = topDeclBox wiki nm hdr
+	   | otherwise  = topDeclBox wiki nm (hdr <+> keyword "where")
 
 	hdr = ppClassHdr summary ctxt nm tvs fds
 
@@ -866,7 +880,7 @@ ppHsClassDecl summary instances orig_c
 	   | otherwise  = 
 		s8 </> meth_hdr </>
 		tda [theclass "body"] << vanillaTable << (
-	       		abovesSep s8 [ ppFunSig summary n ty doc0
+	       		abovesSep s8 [ ppFunSig summary wiki n ty doc0
 			             | HsTypeSig _ [n] ty doc0 <- decls
 			             ]
 			)
@@ -882,7 +896,7 @@ ppHsClassDecl summary instances orig_c
 			aboves (map (declBox.ppInstHead) instances)
 		  ))
 
-ppHsClassDecl _ _ _ d =
+ppHsClassDecl _ _ _ _ d =
     error $ "HaddockHtml.ppHsClassDecl: unexpected decl: " ++ show d
 
 
@@ -893,13 +907,13 @@ ppInstHead (ctxt,asst) =  ppHsContext ctxt <+> darrow <+> ppHsAsst asst
 -- ----------------------------------------------------------------------------
 -- Type signatures
 
-ppFunSig :: Bool -> HsName -> HsType -> Maybe Doc -> HtmlTable
-ppFunSig summary nm ty0 doc
+ppFunSig :: Bool -> WikiInfo -> HsName -> HsType -> Maybe Doc -> HtmlTable
+ppFunSig summary wiki nm ty0 doc
   | summary || no_arg_docs ty0 = 
-      declWithDoc summary doc (ppTypeSig summary nm ty0)
+      declWithDoc summary wiki nm doc (ppTypeSig summary nm ty0)
 
   | otherwise   = 
-	declBox (ppHsBinder False nm) </>
+	topDeclBox wiki nm (ppHsBinder False nm) </>
 	(tda [theclass "body"] << vanillaTable <<  (
 	   do_args dcolon ty0 </>
 	   (if (isJust doc) 
@@ -1142,6 +1156,20 @@ text   = strAttr "TEXT"
 declBox :: Html -> HtmlTable
 declBox html = tda [theclass "decl"] << html
 
+-- a box for top level documented names
+-- it adds a wiki link at the right hand side of the box
+topDeclBox :: Maybe (String, Module) -> HsName -> Html -> HtmlTable
+topDeclBox Nothing name html = declBox html
+topDeclBox (Just (base_url, Module mod)) name html =
+  tda [theclass "topdecl"] <<
+  (        table ! [theclass "declbar"] <<
+	    ((tda [theclass "declname"] << html) <->
+             (tda [theclass "declbut"] << link))
+  )
+  where link = anchor ! [href url] << toHtml "Comments"
+        url = pathJoin [base_url, mod] ++ nameAnchor
+        nameAnchor = '#' : escapeStr (hsNameStr name)
+
 -- a box for displaying an 'argument' (some code which has text to the
 -- right of it).  Wrapping is not allowed in these boxes, whereas it is
 -- in a declBox.
diff --git a/src/Main.hs b/src/Main.hs
index 2d6408f0..70c2dd58 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -235,11 +235,13 @@ run flags files = do
 	die ("-h cannot be used with --gen-index or --gen-contents")
 
   when (Flag_GenContents `elem` flags) $ do
-	ppHtmlContents odir title package maybe_html_help_format maybe_index_url visible_read_ifaces prologue
+	ppHtmlContents odir title package maybe_html_help_format
+            maybe_index_url maybe_wiki_url visible_read_ifaces prologue
         copyHtmlBits odir libdir css_file
 
   when (Flag_GenIndex `elem` flags) $ do
-	ppHtmlIndex odir title package maybe_html_help_format maybe_contents_url visible_read_ifaces
+	ppHtmlIndex odir title package maybe_html_help_format
+            maybe_contents_url maybe_wiki_url visible_read_ifaces
         copyHtmlBits odir libdir css_file
         
   when (Flag_GenContents `elem` flags && Flag_GenIndex `elem` flags) $ do