From 9728087302a03143624d030642770f17be1eb097 Mon Sep 17 00:00:00 2001 From: krasimir Date: Tue, 9 Jul 2002 16:33:33 +0000 Subject: [haddock @ 2002-07-09 16:33:31 by krasimir] 'Microsoft HTML Help' support --- src/HaddockHH.hs | 94 ++++++++++++++++++++++++++++++++++++++++++++++++ src/HaddockHtml.hs | 30 +++------------- src/HaddockModuleTree.hs | 25 +++++++++++++ src/HaddockUtil.hs | 5 +++ 4 files changed, 128 insertions(+), 26 deletions(-) create mode 100644 src/HaddockHH.hs create mode 100644 src/HaddockModuleTree.hs (limited to 'src') diff --git a/src/HaddockHH.hs b/src/HaddockHH.hs new file mode 100644 index 00000000..05ff9243 --- /dev/null +++ b/src/HaddockHH.hs @@ -0,0 +1,94 @@ +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 "

" $+$ + nest 4 (fn [] ts) $+$ + 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 "

" $+$ + nest 4 (fn (s:ss) ts) $+$ + text "" + + ppLeaf s ss isleaf = + text "

" <> nest 4 + (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 "

" $+$ + nest 4 (ppList index) $+$ + 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 "

" $$ + ppList mods \ No newline at end of file diff --git a/src/HaddockHtml.hs b/src/HaddockHtml.hs index 209d9689..a503d50f 100644 --- a/src/HaddockHtml.hs +++ b/src/HaddockHtml.hs @@ -10,6 +10,8 @@ import Prelude hiding (div) import HaddockVersion import HaddockTypes import HaddockUtil +import HaddockModuleTree +import HaddockHH import HsSyn import IO @@ -69,12 +71,10 @@ ppHtml title source_url ifaces odir maybe_css libdir inst_maps prologue = do ppHtmlContents odir title source_url (map fst visible_ifaces) prologue ppHtmlIndex odir title visible_ifaces + ppHHContents odir (map fst visible_ifaces) + ppHHIndex odir visible_ifaces mapM_ (ppHtmlModule odir title source_url inst_maps) visible_ifaces -moduleHtmlFile :: FilePath -> String -> FilePath -moduleHtmlFile "" mod = mod ++ ".html" -- ToDo: Z-encode filename? -moduleHtmlFile dir mod = dir ++ pathSeparator : mod ++ ".html" - contentsHtmlFile = "index.html" indexHtmlFile = "doc-index.html" subIndexHtmlFile k a = "doc-index-" ++ k:a:".html" @@ -198,28 +198,6 @@ mkLeaf s ss True = anchor ! [href (moduleHtmlFile "" mod)] << toHtml s (s':ss') = reverse (s:ss) -- reconstruct the module name -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] - -- --------------------------------------------------------------------------- -- Generate the index diff --git a/src/HaddockModuleTree.hs b/src/HaddockModuleTree.hs new file mode 100644 index 00000000..21cd404e --- /dev/null +++ b/src/HaddockModuleTree.hs @@ -0,0 +1,25 @@ +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] \ No newline at end of file diff --git a/src/HaddockUtil.hs b/src/HaddockUtil.hs index 1e8e2ca8..3e7660bb 100644 --- a/src/HaddockUtil.hs +++ b/src/HaddockUtil.hs @@ -14,6 +14,7 @@ module HaddockUtil ( -- * Filename utilities basename, dirname, splitFilename3, isPathSeparator, pathSeparator, + moduleHtmlFile, -- * Miscellaneous utilities die, dieMsg, mapSnd, mapMaybeM, @@ -209,6 +210,10 @@ isPathSeparator ch = ch == '/' #endif +moduleHtmlFile :: FilePath -> String -> FilePath +moduleHtmlFile "" mod = mod ++ ".html" -- ToDo: Z-encode filename? +moduleHtmlFile dir mod = dir ++ pathSeparator : mod ++ ".html" + ----------------------------------------------------------------------------- -- misc. -- cgit v1.2.3