[[haddock @ 2002-07-10 10:26:11 by simonmar] simonmar**20020710102611 Tweaks to the MS Help support: the extra files are now only generated if you ask for them (--ms-help). ] { hunk ./src/HaddockHH.hs 1 -module HaddockHH(ppHHContents, ppHHIndex) where - -import HsSyn hiding(Doc) -import Text.PrettyPrint -import Data.FiniteMap -import HaddockModuleTree -import HaddockUtil -import HaddockTypes - -contentsHHFile = "index.hhc" -indexHHFile = "index.hhk" - -ppHHContents :: FilePath -> [Module] -> IO () -ppHHContents odir mods = do - let tree = mkModuleTree mods - html = - text "" $$ - text "" $$ - text "" $$ - text "" $$ - text "" $$ - text "" $$ - ppModuleTree tree $$ - text "" - writeFile (odir ++ pathSeparator:contentsHHFile) (render html) - where - ppModuleTree :: [ModuleTree] -> Doc - ppModuleTree ts = - text "" $$ - text "" $$ - text "" $$ - text "" - - fn :: [String] -> [ModuleTree] -> Doc - fn ss [x] = ppNode ss x - fn ss (x:xs) = ppNode ss x $$ fn ss xs - - ppNode :: [String] -> ModuleTree -> Doc - ppNode ss (Node s leaf []) = - ppLeaf s ss leaf - ppNode ss (Node s leaf ts) = - ppLeaf s ss leaf $$ - text "" - - ppLeaf s ss isleaf = - text "
  • " <> nest 4 - (text "" $$ - text " text s <> text "\">" $$ - (if isleaf then text " text (moduleHtmlFile "" mod) <> text "\">" else empty) $$ - text "") $+$ - text "
    • " - where - mod = foldr (++) "" (s' : map ('.':) ss') - (s':ss') = reverse (s:ss) - -- reconstruct the module name - -------------------------------- -ppHHIndex :: FilePath -> [(Module,Interface)] -> IO () -ppHHIndex odir ifaces = do - let html = - text "" $$ - text "" $$ - text "" $$ - text "" $$ - text "" $$ - text "" $$ - text "" $$ - text "" - writeFile (odir ++ pathSeparator:indexHHFile) (render html) - where - index :: [(HsName, Module)] - index = fmToList full_index - - iface_indices = map getIfaceIndex ifaces - full_index = foldr1 plusFM iface_indices - - getIfaceIndex (mod,iface) = listToFM - [ (name, mod) | (name, Qual mod' _) <- fmToList (iface_env iface), mod == mod'] - - ppList [] = empty - ppList ((name,Module mod):mods) = - text "
  • " <> nest 4 - (text "" $$ - text " text (show name) <> text "\">" $$ - text " text (moduleHtmlFile "" mod) <> char '#' <> text (show name) <> text "\">" $$ - text "") $+$ - text "
    • " $$ +module HaddockHH(ppHHContents, ppHHIndex) where + +import HsSyn hiding(Doc) +import Pretty +import FiniteMap +import HaddockModuleTree +import HaddockUtil +import HaddockTypes + +contentsHHFile = "index.hhc" +indexHHFile = "index.hhk" + +ppHHContents :: FilePath -> [Module] -> IO () +ppHHContents odir mods = do + let tree = mkModuleTree mods + html = + text "" $$ + text "" $$ + text "" $$ + text "" $$ + text "" $$ + text "" $$ + ppModuleTree tree $$ + text "" + writeFile (odir ++ pathSeparator:contentsHHFile) (render html) + where + ppModuleTree :: [ModuleTree] -> Doc + ppModuleTree ts = + text "" $$ + text "" $$ + text "" $$ + text "" + + fn :: [String] -> [ModuleTree] -> Doc + fn ss [x] = ppNode ss x + fn ss (x:xs) = ppNode ss x $$ fn ss xs + + ppNode :: [String] -> ModuleTree -> Doc + ppNode ss (Node s leaf []) = + ppLeaf s ss leaf + ppNode ss (Node s leaf ts) = + ppLeaf s ss leaf $$ + text "" + + ppLeaf s ss isleaf = + text "
  • " <> nest 4 + (text "" $$ + text " text s <> text "\">" $$ + (if isleaf then text " text (moduleHtmlFile "" mod) <> text "\">" else empty) $$ + text "") $+$ + text "
    • " + where + mod = foldr (++) "" (s' : map ('.':) ss') + (s':ss') = reverse (s:ss) + -- reconstruct the module name + +------------------------------- +ppHHIndex :: FilePath -> [(Module,Interface)] -> IO () +ppHHIndex odir ifaces = do + let html = + text "" $$ + text "" $$ + text "" $$ + text "" $$ + text "" $$ + text "" $$ + text "" $$ + text "" + writeFile (odir ++ pathSeparator:indexHHFile) (render html) + where + index :: [(HsName, Module)] + index = fmToList full_index + + iface_indices = map getIfaceIndex ifaces + full_index = foldr1 plusFM iface_indices + + getIfaceIndex (mod,iface) = listToFM + [ (name, mod) | (name, Qual mod' _) <- fmToList (iface_env iface), mod == mod'] + + ppList [] = empty + ppList ((name,Module mod):mods) = + text "
  • " <> nest 4 + (text "" $$ + text " text (show name) <> text "\">" $$ + text " text (moduleHtmlFile "" mod) <> char '#' <> text (show name) <> text "\">" $$ + text "") $+$ + text "
    • " $$ hunk ./src/HaddockHH.hs 95 + hunk ./src/HaddockHtml.hs 52 + -> Bool -- do MS Help stuff hunk ./src/HaddockHtml.hs 55 -ppHtml title source_url ifaces odir maybe_css libdir inst_maps prologue = do +ppHtml title source_url ifaces odir maybe_css libdir inst_maps prologue + do_ms_help = do hunk ./src/HaddockHtml.hs 76 - ppHHContents odir (map fst visible_ifaces) - ppHHIndex odir visible_ifaces + + -- Generate index and contents page for MS help if requested + when do_ms_help $ do + ppHHContents odir (map fst visible_ifaces) + ppHHIndex odir visible_ifaces + hunk ./src/HaddockHtml.hs 83 + hunk ./src/Main.hs 58 - = Flag_Verbose - | Flag_DocBook + = Flag_CSS String hunk ./src/Main.hs 60 - | Flag_Html + | Flag_DocBook + | Flag_DumpInterface FilePath hunk ./src/Main.hs 63 - | Flag_Prologue FilePath - | Flag_SourceURL String - | Flag_CSS String + | Flag_Html hunk ./src/Main.hs 65 + | Flag_MSHtmlHelp + | Flag_NoImplicitPrelude hunk ./src/Main.hs 68 + | Flag_Prologue FilePath hunk ./src/Main.hs 70 - | Flag_DumpInterface FilePath - | Flag_NoImplicitPrelude + | Flag_SourceURL String + | Flag_Verbose hunk ./src/Main.hs 99 - "Directory containing Haddock's auxiliary files", + "Location of Haddock's auxiliary files", hunk ./src/Main.hs 101 - "Do not assume Prelude is imported" + "Do not assume Prelude is imported", + Option [] ["ms-help"] (NoArg Flag_MSHtmlHelp) + "Produce Microsoft HTML Help files (with -h)" hunk ./src/Main.hs 184 - libdir inst_maps prologue + libdir inst_maps prologue (Flag_MSHtmlHelp `elem` flags) }