diff options
| -rw-r--r-- | src/HaddockHtml.hs | 81 | ||||
| -rw-r--r-- | src/Main.hs | 48 |
2 files changed, 68 insertions, 61 deletions
diff --git a/src/HaddockHtml.hs b/src/HaddockHtml.hs index edc5a7b5..272d2ea6 100644 --- a/src/HaddockHtml.hs +++ b/src/HaddockHtml.hs @@ -34,6 +34,10 @@ import Data.Maybe ( fromJust, isJust, mapMaybe, fromMaybe ) import Foreign.Marshal.Alloc ( allocaBytes ) import System.IO ( IOMode(..), hClose, hGetBuf, hPutBuf ) +-- the base, module and entity URLs for the source code and wiki links. +type SourceURLs = (Maybe String, Maybe String, Maybe String) +type WikiURLs = (Maybe String, Maybe String, Maybe String) + -- ----------------------------------------------------------------------------- -- Generating HTML documentation @@ -43,8 +47,8 @@ ppHtml :: String -> 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) + -> SourceURLs -- the source URL (--source) + -> WikiURLs -- the wiki URL (--wiki) -> Maybe String -- the contents URL (--use-contents) -> Maybe String -- the index URL (--use-index) -> IO () @@ -135,16 +139,18 @@ footer = ) -srcButton :: Maybe String -> Maybe Interface -> HtmlTable -srcButton maybe_source_url iface - | Just u <- maybe_source_url = - let src_url = spliceURL (fmap iface_orig_filename iface) - (fmap iface_module iface) Nothing u - in - topButBox (anchor ! [href src_url] << toHtml "Source code") - | otherwise = - Html.emptyTable - +srcButton :: SourceURLs -> Maybe Interface -> HtmlTable +srcButton (Just src_base_url, _, _) Nothing = + topButBox (anchor ! [href src_base_url] << toHtml "Source code") + +srcButton (_, Just src_module_url, _) (Just iface) = + let url = spliceURL (Just $ iface_orig_filename iface) + (Just $ iface_module iface) Nothing src_module_url + in topButBox (anchor ! [href url] << toHtml "Source code") + +srcButton _ _ = + Html.emptyTable + spliceURL :: Maybe FilePath -> Maybe Module -> Maybe HsName -> String -> String spliceURL maybe_file maybe_mod maybe_name url = run url where @@ -170,32 +176,22 @@ spliceURL maybe_file maybe_mod maybe_name url = run url run ('%':'{':'N':'A':'M':'E':'}':rest) = name ++ run rest run ('%':'{':'K':'I':'N':'D':'}':rest) = kind ++ run rest - run ('%':'{':'M':'O':'D':'U':'L':'E':'|':rest) = subst mod rest - run ('%':'{':'F':'I':'L':'E':'|':rest) = subst file rest - run ('%':'{':'N':'A':'M':'E':'|':rest) = subst name rest - run ('%':'{':'K':'I':'N':'D':'|':rest) = subst kind rest - run ('%':'{':'M':'O':'D':'U':'L':'E':'/':'.':'/':c:'}':rest) = map (\x -> if x == '.' then c else x) mod ++ run rest - run ('%':'{':'M':'O':'D':'U':'L':'E':'/':'.':'/':c:'|':rest) = - subst (map (\x -> if x == '.' then c else x) mod) rest run (c:rest) = c : run rest - subst "" rest = skip rest - subst s ('%':rest) = s ++ subst s rest - subst s ('}':rest) = run rest - subst s ( c :rest) = c : subst s rest - subst s [] = error "malformed URL substitution" +wikiButton :: WikiURLs -> Maybe Module -> HtmlTable +wikiButton (Just wiki_base_url, _, _) Nothing = + topButBox (anchor ! [href wiki_base_url] << toHtml "User Comments") - skip ('}':rest) = run rest - skip ( _ :rest) = skip rest +wikiButton (_, Just wiki_module_url, _) (Just mod) = + let url = spliceURL Nothing (Just mod) Nothing wiki_module_url + in topButBox (anchor ! [href url] << toHtml "User Comments") + +wikiButton _ _ = + Html.emptyTable -wikiButton :: Maybe String -> Maybe Module -> HtmlTable -wikiButton Nothing _ = Html.emptyTable -wikiButton (Just url) maybe_mod - = topButBox (anchor ! [href url'] << toHtml "User Comments") - where url' = spliceURL Nothing maybe_mod Nothing url contentsButton :: Maybe String -> HtmlTable contentsButton maybe_contents_url @@ -212,7 +208,7 @@ indexButton maybe_index_url Just url -> url simpleHeader :: String -> Maybe String -> Maybe String - -> Maybe String -> Maybe String -> HtmlTable + -> SourceURLs -> WikiURLs -> HtmlTable simpleHeader doctitle maybe_contents_url maybe_index_url maybe_source_url maybe_wiki_url = (tda [theclass "topbar"] << @@ -227,7 +223,7 @@ simpleHeader doctitle maybe_contents_url maybe_index_url )) pageHeader :: String -> Interface -> String - -> Maybe String -> Maybe String + -> SourceURLs -> WikiURLs -> Maybe String -> Maybe String -> HtmlTable pageHeader mdl iface doctitle maybe_source_url maybe_wiki_url @@ -283,8 +279,8 @@ ppHtmlContents -> Maybe String -> Maybe String -> Maybe String - -> Maybe String - -> Maybe String + -> SourceURLs + -> WikiURLs -> [Interface] -> Maybe Doc -> IO () ppHtmlContents odir doctitle @@ -393,8 +389,8 @@ ppHtmlIndex :: FilePath -> Maybe String -> Maybe String -> Maybe String - -> Maybe String - -> Maybe String + -> SourceURLs + -> WikiURLs -> [Interface] -> IO () ppHtmlIndex odir doctitle maybe_package maybe_html_help_format @@ -519,7 +515,7 @@ ppHtmlIndex odir doctitle maybe_package maybe_html_help_format ppHtmlModule :: FilePath -> String - -> Maybe String -> Maybe String + -> SourceURLs -> WikiURLs -> Maybe String -> Maybe String -> Interface -> IO () ppHtmlModule odir doctitle @@ -541,7 +537,7 @@ ppHtmlModule odir doctitle ) writeFile (pathJoin [odir, moduleHtmlFile mdl]) (renderHtml html) -ifaceToHtml :: Maybe String -> Maybe String -> Interface -> HtmlTable +ifaceToHtml :: SourceURLs -> WikiURLs -> Interface -> HtmlTable ifaceToHtml maybe_source_url maybe_wiki_url iface = abovesSep s15 (contents: description: synopsis: maybe_doc_hdr: bdy) where @@ -620,7 +616,7 @@ numberSectionHeadings exports = go 1 exports = other : go n es -- The URL for source and wiki links, and the current module -type LinksInfo = (Maybe String, Maybe String, Interface) +type LinksInfo = (SourceURLs, WikiURLs, Interface) processExport :: Bool -> LinksInfo -> ExportItem -> HtmlTable processExport _ _ (ExportGroup lev id0 doc) @@ -1201,8 +1197,9 @@ declBox html = tda [theclass "decl"] << html -- a box for top level documented names -- it adds a source and wiki link at the right hand side of the box topDeclBox :: LinksInfo -> SrcLoc -> HsName -> Html -> HtmlTable -topDeclBox (Nothing, Nothing, _) srcloc name html = declBox html -topDeclBox (maybe_source_url, maybe_wiki_url, iface) (SrcLoc _ _ fname) name html = +topDeclBox ((_,_,Nothing), (_,_,Nothing), _) _ _ html = declBox html +topDeclBox ((_,_,maybe_source_url), (_,_,maybe_wiki_url), iface) + (SrcLoc _ _ fname) name html = tda [theclass "topdecl"] << ( table ! [theclass "declbar"] << ((tda [theclass "declname"] << html) diff --git a/src/Main.hs b/src/Main.hs index 491eeccf..0fe593ff 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -31,7 +31,7 @@ import Control.Monad.Writer ( Writer, runWriter, tell ) import Data.Char ( isSpace ) import Data.IORef ( writeIORef ) import Data.List ( nub, (\\), foldl', sortBy ) -import Data.Maybe ( isJust, isNothing, maybeToList ) +import Data.Maybe ( isJust, isNothing, maybeToList, listToMaybe ) --import Debug.Trace import System.Console.GetOpt ( getOpt, usageInfo, ArgOrder(..), OptDescr(..), ArgDescr(..) ) import System.Environment ( getArgs ) @@ -78,8 +78,12 @@ data Flag | Flag_OutputDir FilePath | Flag_Prologue FilePath | Flag_ReadInterface FilePath - | Flag_SourceURL String - | Flag_WikiURL String + | Flag_SourceBaseURL String + | Flag_SourceModuleURL String + | Flag_SourceEntityURL String + | Flag_WikiBaseURL String + | Flag_WikiModuleURL String + | Flag_WikiEntityURL String | Flag_Help | Flag_Verbose | Flag_Version @@ -109,10 +113,18 @@ options = "output in HTML", Option [] ["html-help"] (ReqArg Flag_HtmlHelp "format") "produce index and table of contents in mshelp, mshelp2 or devhelp format (with -h)", - Option ['s'] ["source"] (ReqArg Flag_SourceURL "URL") - "base URL for links to source code", - Option [] ["wiki"] (ReqArg Flag_WikiURL "URL") - "base URL for links to a wiki", + Option [] ["source-base"] (ReqArg Flag_SourceBaseURL "URL") + "URL for a source code link on the contents\nand index pages", + Option ['s'] ["source", "source-module"] (ReqArg Flag_SourceModuleURL "URL") + "URL for a source code link for each module\n(using the %{FILE} or %{MODULE} vars)", + Option [] ["source-entity"] (ReqArg Flag_SourceEntityURL "URL") + "URL for a source code link for each entity\n(using the %{FILE}, %{MODULE} or %{NAME} vars)", + Option [] ["comments-base"] (ReqArg Flag_WikiBaseURL "URL") + "URL for a comments link on the contents\nand index pages", + Option [] ["comments-module"] (ReqArg Flag_WikiModuleURL "URL") + "URL for a comments link for each module\n(using the %{MODULE} var)", + Option [] ["comments-entity"] (ReqArg Flag_WikiEntityURL "URL") + "URL for a comments link for each entity\n(using the %{FILE}, %{MODULE} or %{NAME} vars)", Option ['c'] ["css"] (ReqArg Flag_CSS "FILE") "the CSS file to use for HTML output", Option ['p'] ["prologue"] (ReqArg Flag_Prologue "FILE") @@ -160,17 +172,15 @@ run flags files = do [] -> "" (t:_) -> t - package = case [str | Flag_Package str <- flags] of - [] -> Nothing - (t:_) -> Just t + package = listToMaybe [str | Flag_Package str <- flags] - maybe_source_url = case [str | Flag_SourceURL str <- flags] of - [] -> Nothing - (t:_) -> Just t + maybe_source_urls = (listToMaybe [str | Flag_SourceBaseURL str <- flags] + ,listToMaybe [str | Flag_SourceModuleURL str <- flags] + ,listToMaybe [str | Flag_SourceEntityURL str <- flags]) - maybe_wiki_url = case [str | Flag_WikiURL str <- flags] of - [] -> Nothing - (t:_) -> Just t + maybe_wiki_urls = (listToMaybe [str | Flag_WikiBaseURL str <- flags] + ,listToMaybe [str | Flag_WikiModuleURL str <- flags] + ,listToMaybe [str | Flag_WikiEntityURL str <- flags]) verbose = Flag_Verbose `elem` flags @@ -236,13 +246,13 @@ run flags files = do when (Flag_GenContents `elem` flags) $ do ppHtmlContents odir title package maybe_html_help_format - maybe_index_url maybe_source_url maybe_wiki_url + maybe_index_url maybe_source_urls maybe_wiki_urls 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 maybe_source_url maybe_wiki_url + maybe_contents_url maybe_source_urls maybe_wiki_urls visible_read_ifaces copyHtmlBits odir libdir css_file @@ -305,7 +315,7 @@ run flags files = do when (Flag_Html `elem` flags) $ do ppHtml title package these_ifaces odir prologue maybe_html_help_format - maybe_source_url maybe_wiki_url + maybe_source_urls maybe_wiki_urls maybe_contents_url maybe_index_url copyHtmlBits odir libdir css_file |