[[haddock @ 2002-07-09 16:33:31 by krasimir] krasimir**20020709163333 'Microsoft HTML Help' support ] { addfile ./src/HaddockHH.hs addfile ./src/HaddockModuleTree.hs 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 "
    • " $$ + ppList mods hunk ./src/HaddockHtml.hs 13 +import HaddockModuleTree +import HaddockHH hunk ./src/HaddockHtml.hs 74 + ppHHContents odir (map fst visible_ifaces) + ppHHIndex odir visible_ifaces hunk ./src/HaddockHtml.hs 78 -moduleHtmlFile :: FilePath -> String -> FilePath -moduleHtmlFile "" mod = mod ++ ".html" -- ToDo: Z-encode filename? -moduleHtmlFile dir mod = dir ++ pathSeparator : mod ++ ".html" - hunk ./src/HaddockHtml.hs 200 - -data ModuleTree = Node String Bool [ModuleTree] - -mkModuleTree :: [Module] -> [ModuleTree] -mkModuleTree mods = foldr addToTrees [] (map splitModule mods) - -addToTrees :: [String] -> [ModuleTree] -> [ModuleTree] -addToTrees [] ts = ts -addToTrees ss [] = mkSubTree ss -addToTrees (s1:ss) (t@(Node s2 leaf subs) : ts) - | s1 > s2 = t : addToTrees (s1:ss) ts - | s1 == s2 = Node s2 (leaf || null ss) (addToTrees ss subs) : ts - | otherwise = mkSubTree (s1:ss) ++ t : ts - -mkSubTree [] = [] -mkSubTree (s:ss) = [Node s (null ss) (mkSubTree ss)] - -splitModule :: Module -> [String] -splitModule (Module mod) = split mod - where split mod = case break (== '.') mod of - (s1, '.':s2) -> s1 : split s2 - (s1, _) -> [s1] hunk ./src/HaddockModuleTree.hs 1 - +module HaddockModuleTree(ModuleTree(..), mkModuleTree) where + +import HsSyn + +data ModuleTree = Node String Bool [ModuleTree] + +mkModuleTree :: [Module] -> [ModuleTree] +mkModuleTree mods = foldr addToTrees [] (map splitModule mods) + +addToTrees :: [String] -> [ModuleTree] -> [ModuleTree] +addToTrees [] ts = ts +addToTrees ss [] = mkSubTree ss +addToTrees (s1:ss) (t@(Node s2 leaf subs) : ts) + | s1 > s2 = t : addToTrees (s1:ss) ts + | s1 == s2 = Node s2 (leaf || null ss) (addToTrees ss subs) : ts + | otherwise = mkSubTree (s1:ss) ++ t : ts + +mkSubTree [] = [] +mkSubTree (s:ss) = [Node s (null ss) (mkSubTree ss)] + +splitModule :: Module -> [String] +splitModule (Module mod) = split mod + where split mod = case break (== '.') mod of + (s1, '.':s2) -> s1 : split s2 + (s1, _) -> [s1] hunk ./src/HaddockUtil.hs 17 + moduleHtmlFile, hunk ./src/HaddockUtil.hs 212 + +moduleHtmlFile :: FilePath -> String -> FilePath +moduleHtmlFile "" mod = mod ++ ".html" -- ToDo: Z-encode filename? +moduleHtmlFile dir mod = dir ++ pathSeparator : mod ++ ".html" }