diff options
| -rw-r--r-- | src/HaddockDevHelp.hs | 76 | ||||
| -rw-r--r-- | src/HaddockHtml.hs | 10 |
2 files changed, 82 insertions, 4 deletions
diff --git a/src/HaddockDevHelp.hs b/src/HaddockDevHelp.hs new file mode 100644 index 00000000..95987230 --- /dev/null +++ b/src/HaddockDevHelp.hs @@ -0,0 +1,76 @@ +module HaddockDevHelp(ppDevHelpFile) where + +import HsSyn hiding(Doc) + +#if __GLASGOW_HASKELL__ < 503 +import Pretty +import FiniteMap +#else +import Text.PrettyPrint +import Data.FiniteMap +import Data.Char +#endif + +import Maybe ( fromMaybe ) +import HaddockModuleTree +import HaddockUtil +import HaddockTypes + + +ppDevHelpFile :: FilePath -> String -> Maybe String -> [(Module,Interface)] -> IO () +ppDevHelpFile odir doctitle maybe_package ifaces = do + let devHelpFile = package++".devhelp" + tree = mkModuleTree [(mod,iface_package iface) | (mod,iface) <- ifaces] + doc = + text "<?xml version=\"1.0\" encoding=\"utf-8\" standalone=\"no\"?>" $$ + (text "<book xmlns=\"http://www.devhelp.net/book\" title=\""<>text doctitle<> + text "\" link=\""<>text contentsHtmlFile<>text"\" author=\"\" name=\""<>text package<>text "\">") $$ + text "<chapters>" $$ + nest 4 (ppModuleTree [] tree) $+$ + text "</chapters>" $$ + text "<functions>" $$ + nest 4 (ppList index) $+$ + text "</functions>" $$ + text "</book>" + writeFile (odir ++ pathSeparator:devHelpFile) (render doc) + where + package = fromMaybe "pkg" maybe_package + + ppModuleTree :: [String] -> [ModuleTree] -> Doc + ppModuleTree ss [x] = ppNode ss x + ppModuleTree ss (x:xs) = ppNode ss x $$ ppModuleTree ss xs + ppModuleTree _ [] = error "HaddockHH.ppHHContents.fn: no module trees given" + + ppNode :: [String] -> ModuleTree -> Doc + ppNode ss (Node s leaf _pkg ts) = + case ts of + [] -> text "<sub"<+>ppAttribs<>text "/>" + ts -> + text "<sub"<+>ppAttribs<>text ">" $$ + nest 4 (ppModuleTree (s:ss) ts) $+$ + text "</sub>" + where + ppLink | leaf = text (moduleHtmlFile "" mdl) + | otherwise = empty + + ppAttribs = text "name="<>doubleQuotes (text s)<+>text "link="<>doubleQuotes ppLink + + mdl = foldr (++) "" (s' : map ('.':) ss') + (s':ss') = reverse (s:ss) + -- reconstruct the module name + + index :: [(HsName, [Module])] + index = fmToList (foldr getIfaceIndex emptyFM ifaces) + + getIfaceIndex (mdl,iface) fm = + addListToFM_C (++) fm [(name, [mdl]) | (name, Qual mdl' _) <- fmToList (iface_env iface), mdl == mdl'] + + ppList [] = empty + ppList ((name,refs):mdls) = + ppReference name refs $$ + ppList mdls + + ppReference name [] = empty + ppReference name (Module mdl:refs) = + text "<function name=\""<>text (escapeStr (show name))<>text"\" link=\""<>text (nameHtmlRef "" mdl name)<>text"\"/>" $$ + ppReference name refs diff --git a/src/HaddockHtml.hs b/src/HaddockHtml.hs index 719186ab..2c6fedb9 100644 --- a/src/HaddockHtml.hs +++ b/src/HaddockHtml.hs @@ -17,6 +17,7 @@ import HaddockUtil import HaddockModuleTree import HaddockHH import HaddockHH2 +import HaddockDevHelp import HsSyn import Maybe ( fromJust, isJust ) @@ -86,13 +87,12 @@ ppHtmlHelpFiles doctitle maybe_package ifaces odir maybe_html_help_format = do -- Generate index and contents page for Html Help if requested case maybe_html_help_format of - Just "mshelp" -> do - ppHHProject odir doctitle maybe_package visible_ifaces + Just "mshelp" -> ppHHProject odir doctitle maybe_package visible_ifaces Just "mshelp2" -> do ppHH2Files odir maybe_package visible_ifaces ppHH2Collection odir doctitle maybe_package - _ -> return () - + Just "devhelp" -> ppDevHelpFile odir doctitle maybe_package visible_ifaces + Just format -> fail ("The "++format++" format is not implemented") copyFile :: FilePath -> FilePath -> IO () copyFile fromFPath toFPath = @@ -234,6 +234,7 @@ ppHtmlContents odir doctitle maybe_package maybe_html_help_format maybe_index_ur Nothing -> return () Just "mshelp" -> ppHHContents odir maybe_package tree Just "mshelp2" -> ppHH2Contents odir maybe_package tree + Just "devhelp" -> return () Just format -> fail ("The "++format++" format is not implemented") ppPrologue :: String -> Maybe Doc -> HtmlTable @@ -319,6 +320,7 @@ ppHtmlIndex odir doctitle maybe_package maybe_html_help_format maybe_contents_ur Nothing -> return () Just "mshelp" -> ppHHIndex odir maybe_package ifaces Just "mshelp2" -> ppHH2Index odir maybe_package ifaces + Just "devhelp" -> return () Just format -> fail ("The "++format++" format is not implemented") where split_indices = length index > 50 |