From aa36c783045c5116b773ef5a4e843d916dbe6e3c Mon Sep 17 00:00:00 2001
From: Duncan Coutts <duncan.coutts@worc.ox.ac.uk>
Date: Tue, 17 Jan 2006 19:29:55 +0000
Subject: Add a --wiki=URL flag to add a per-module link to a correspondng wiki
 page. So each html page gets an extra link (placed next to the source code
 and contents links) to a corresponding wiki page. The idea is to let readers
 contribute their own notes, examples etc to the documentation.

Also slightly tidy up the code for the --source option.
---
 src/HaddockHtml.hs | 42 ++++++++++++++++++++++++++++++------------
 1 file changed, 30 insertions(+), 12 deletions(-)

(limited to 'src/HaddockHtml.hs')

diff --git a/src/HaddockHtml.hs b/src/HaddockHtml.hs
index 4f64d1f7..4c98bc51 100644
--- a/src/HaddockHtml.hs
+++ b/src/HaddockHtml.hs
@@ -39,16 +39,18 @@ import System.IO ( IOMode(..), hClose, hGetBuf, hPutBuf )
 
 ppHtml	:: String
 	-> Maybe String				-- package
-	-> Maybe String
 	-> [Interface]
 	-> FilePath			-- destination directory
 	-> Maybe Doc			-- prologue text, maybe
 	-> Maybe String		-- the Html Help format (--html-help)
+	-> Maybe String			-- the source URL (--source)
+	-> Maybe String			-- the wiki URL (--wiki)
 	-> Maybe String			-- the contents URL (--use-contents)
 	-> Maybe String			-- the index URL (--use-index)
 	-> IO ()
 
-ppHtml doctitle maybe_package source_url ifaces odir prologue maybe_html_help_format
+ppHtml doctitle maybe_package ifaces odir prologue maybe_html_help_format
+	maybe_source_url maybe_wiki_url
 	maybe_contents_url maybe_index_url =  do
   let
 	visible_ifaces = filter visible ifaces
@@ -66,7 +68,8 @@ ppHtml doctitle maybe_package source_url ifaces odir prologue maybe_html_help_fo
   when (not (isJust maybe_contents_url && isJust maybe_index_url)) $ 
 	ppHtmlHelpFiles doctitle maybe_package ifaces odir maybe_html_help_format []
 
-  mapM_ (ppHtmlModule odir doctitle source_url 
+  mapM_ (ppHtmlModule odir doctitle
+	   maybe_source_url maybe_wiki_url
 	   maybe_contents_url maybe_index_url) visible_ifaces
 
 ppHtmlHelpFiles	
@@ -130,9 +133,9 @@ footer =
 	)
    
 
-src_button :: Maybe String -> String -> Interface -> HtmlTable
-src_button source_url _ iface
-  | Just u <- source_url = 
+srcButton :: Maybe String -> String -> Interface -> HtmlTable
+srcButton maybe_source_url _ iface
+  | Just u <- maybe_source_url =
 	let src_url = spliceSrcURL iface u
 	in
 	topButBox (anchor ! [href src_url] << toHtml "Source code")
@@ -149,6 +152,13 @@ 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 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
+
 contentsButton :: Maybe String -> HtmlTable
 contentsButton maybe_contents_url 
   = topButBox (anchor ! [href url] << toHtml "Contents")
@@ -175,15 +185,19 @@ simpleHeader doctitle maybe_contents_url maybe_index_url =
    ))
 
 pageHeader :: String -> Interface -> String
-    -> Maybe String -> Maybe String -> Maybe String -> HtmlTable
-pageHeader mdl iface doctitle source_url maybe_contents_url maybe_index_url =
+    -> Maybe String -> Maybe String
+    -> Maybe String -> Maybe String -> HtmlTable
+pageHeader mdl iface doctitle
+           maybe_source_url maybe_wiki_url
+           maybe_contents_url maybe_index_url =
   (tda [theclass "topbar"] << 
     vanillaTable << (
        (td << 
   	image ! [src "haskell_icon.gif", width "16", height 16, alt " "]
        ) <->
        (tda [theclass "title"] << toHtml doctitle) <->
-	src_button source_url mdl iface <->
+	srcButton maybe_source_url mdl iface <->
+	wikiButton maybe_wiki_url iface <->
 	contentsButton maybe_contents_url <->
 	indexButton maybe_index_url
     )
@@ -453,9 +467,12 @@ ppHtmlIndex odir doctitle maybe_package maybe_html_help_format maybe_contents_ur
 -- Generate the HTML page for a module
 
 ppHtmlModule
-	:: FilePath -> String -> Maybe String -> Maybe String -> Maybe String
+	:: FilePath -> String
+	-> Maybe String -> Maybe String
+	-> Maybe String -> Maybe String
 	-> Interface -> IO ()
-ppHtmlModule odir doctitle source_url 
+ppHtmlModule odir doctitle
+  maybe_source_url maybe_wiki_url
   maybe_contents_url maybe_index_url iface = do
   let 
       Module mdl = iface_module iface
@@ -465,7 +482,8 @@ ppHtmlModule odir doctitle source_url
 		styleSheet +++
 		(script ! [src jsFile, thetype "text/javascript"] $ noHtml)) +++
         body << vanillaTable << (
-	    pageHeader mdl iface doctitle source_url 
+	    pageHeader mdl iface doctitle
+		maybe_source_url maybe_wiki_url
 		maybe_contents_url maybe_index_url </> s15 </>
 	    ifaceToHtml mdl iface </> s15 </>
 	    footer
-- 
cgit v1.2.3