diff options
| -rw-r--r-- | src/HaddockHH.hs | 82 | ||||
| -rw-r--r-- | src/HaddockHtml.hs | 6 |
2 files changed, 73 insertions, 15 deletions
diff --git a/src/HaddockHH.hs b/src/HaddockHH.hs index 26269919..98dac72a 100644 --- a/src/HaddockHH.hs +++ b/src/HaddockHH.hs @@ -1,4 +1,4 @@ -module HaddockHH(ppHHContents, ppHHIndex) where +module HaddockHH(ppHHContents, ppHHIndex, ppHHProject) where import HsSyn hiding(Doc) @@ -8,19 +8,20 @@ import FiniteMap #else import Text.PrettyPrint import Data.FiniteMap +import Data.Char #endif +import Maybe ( fromMaybe ) import HaddockModuleTree import HaddockUtil import HaddockTypes -contentsHHFile, indexHHFile :: String -contentsHHFile = "index.hhc" -indexHHFile = "index.hhk" -ppHHContents :: FilePath -> [ModuleTree] -> IO () -ppHHContents odir tree = do - let html = +ppHHContents :: FilePath -> Maybe String -> [ModuleTree] -> IO () +ppHHContents odir maybe_package tree = do + let contentsHHFile = package++".hhc" + + html = text "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML//EN\">" $$ text "<HTML>" $$ text "<HEAD>" $$ @@ -31,6 +32,8 @@ ppHHContents odir tree = do text "</BODY><HTML>" writeFile (odir ++ pathSeparator:contentsHHFile) (render html) where + package = fromMaybe "pkg" maybe_package + ppModuleTree :: [ModuleTree] -> Doc ppModuleTree ts = text "<OBJECT type=\"text/site properties\">" $$ @@ -67,9 +70,11 @@ ppHHContents odir tree = do -- reconstruct the module name ------------------------------- -ppHHIndex :: FilePath -> [(Module,Interface)] -> IO () -ppHHIndex odir ifaces = do - let html = +ppHHIndex :: FilePath -> Maybe String -> [(Module,Interface)] -> IO () +ppHHIndex odir maybe_package ifaces = do + let indexHHFile = package++".hhk" + + html = text "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML//EN\">" $$ text "<HTML>" $$ text "<HEAD>" $$ @@ -81,7 +86,9 @@ ppHHIndex odir ifaces = do text "</UL>" $$ text "</BODY><HTML>" writeFile (odir ++ pathSeparator:indexHHFile) (render html) - where + where + package = fromMaybe "pkg" maybe_package + index :: [(HsName, [Module])] index = fmToList (foldr getIfaceIndex emptyFM ifaces) @@ -89,11 +96,60 @@ ppHHIndex odir ifaces = do addListToFM_C (++) fm [(name, [mdl]) | (name, Qual mdl' _) <- fmToList (iface_env iface), mdl == mdl'] ppList [] = empty - ppList ((name,(Module mdl:_)):mdls) = + ppList ((name,refs):mdls) = text "<LI>" <> nest 4 (text "<OBJECT type=\"text/sitemap\">" $$ text "<PARAM name=\"Name\" value=\"" <> text (show name) <> text "\">" $$ - text "<PARAM name=\"Local\" value=\"" <> text (nameHtmlRef "" mdl name) <> text "\">" $$ + ppReference name refs $$ text "</OBJECT>") $+$ text "</LI>" $$ ppList mdls + + ppReference name [] = empty + ppReference name (Module mdl:refs) = + text "<PARAM name=\"Local\" value=\"" <> text (nameHtmlRef "" mdl name) <> text "\">" $$ + ppReference name refs + + +ppHHProject :: FilePath -> String -> Maybe String -> [(Module,Interface)] -> IO () +ppHHProject odir doctitle maybe_package ifaces = do + let projectHHFile = package++".hhp" + doc = + text "[OPTIONS]" $$ + text "Compatibility=1.1 or later" $$ + text "Compiled file=" <> text package <> text ".chm" $$ + text "Contents file=" <> text package <> text ".hhc" $$ + text "Default topic=" <> text contentsHtmlFile $$ + text "Display compile progress=No" $$ + text "Index file=" <> text package <> text ".hhk" $$ + text "Title=" <> text doctitle $$ + space $$ + text "[FILES]" $$ + ppMods ifaces $$ + text contentsHtmlFile $$ + text indexHtmlFile $$ + ppIndexFiles chars $$ + text cssFile $$ + text iconFile $$ + text jsFile $$ + text plusFile $$ + text minusFile + writeFile (odir ++ pathSeparator:projectHHFile) (render doc) + where + package = fromMaybe "pkg" maybe_package + + ppMods [] = empty + ppMods ((Module mdl,_):ifaces) = + text (moduleHtmlFile "" mdl) $$ + ppMods ifaces + + ppIndexFiles [] = empty + ppIndexFiles (c:cs) = + text (subIndexHtmlFile c) $$ + ppIndexFiles cs + + chars :: [Char] + chars = keysFM (foldr getIfaceIndex emptyFM ifaces) + + getIfaceIndex (mdl,iface) fm = + addListToFM fm [(toUpper (head (show name)),()) | (name, Qual mdl' _) <- fmToList (iface_env iface), mdl == mdl'] diff --git a/src/HaddockHtml.hs b/src/HaddockHtml.hs index eda488e3..719186ab 100644 --- a/src/HaddockHtml.hs +++ b/src/HaddockHtml.hs @@ -86,6 +86,8 @@ 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 "mshelp2" -> do ppHH2Files odir maybe_package visible_ifaces ppHH2Collection odir doctitle maybe_package @@ -230,7 +232,7 @@ ppHtmlContents odir doctitle maybe_package maybe_html_help_format maybe_index_ur -- Generate contents page for Html Help if requested case maybe_html_help_format of Nothing -> return () - Just "mshelp" -> ppHHContents odir tree + Just "mshelp" -> ppHHContents odir maybe_package tree Just "mshelp2" -> ppHH2Contents odir maybe_package tree Just format -> fail ("The "++format++" format is not implemented") @@ -315,7 +317,7 @@ ppHtmlIndex odir doctitle maybe_package maybe_html_help_format maybe_contents_ur -- Generate index and contents page for Html Help if requested case maybe_html_help_format of Nothing -> return () - Just "mshelp" -> ppHHIndex odir ifaces + Just "mshelp" -> ppHHIndex odir maybe_package ifaces Just "mshelp2" -> ppHH2Index odir maybe_package ifaces Just format -> fail ("The "++format++" format is not implemented") where |