diff options
| -rw-r--r-- | src/HaddockHH.hs | 94 | ||||
| -rw-r--r-- | src/HaddockHtml.hs | 30 | ||||
| -rw-r--r-- | src/HaddockModuleTree.hs | 25 | ||||
| -rw-r--r-- | src/HaddockUtil.hs | 5 |
4 files changed, 128 insertions, 26 deletions
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 "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML//EN\">" $$
+ text "<HTML>" $$
+ text "<HEAD>" $$
+ text "<META name=\"GENERATOR\" content=\"Haddock\">" $$
+ text "<!-- Sitemap 1.0 -->" $$
+ text "</HEAD><BODY>" $$
+ ppModuleTree tree $$
+ text "</BODY><HTML>"
+ writeFile (odir ++ pathSeparator:contentsHHFile) (render html)
+ where
+ ppModuleTree :: [ModuleTree] -> Doc
+ ppModuleTree ts =
+ text "<OBJECT type=\"text/site properties\">" $$
+ text "<PARAM name=\"FrameName\" value=\"main\">" $$
+ text "</OBJECT>" $$
+ text "<UL>" $+$
+ nest 4 (fn [] ts) $+$
+ text "</UL>"
+
+ 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 "<UL>" $+$
+ nest 4 (fn (s:ss) ts) $+$
+ text "</UL>"
+
+ ppLeaf s ss isleaf =
+ text "<LI>" <> nest 4
+ (text "<OBJECT type=\"text/sitemap\">" $$
+ text "<PARAM name=\"Name\" value=\"" <> text s <> text "\">" $$
+ (if isleaf then text "<PARAM name=\"Local\" value=\"" <> text (moduleHtmlFile "" mod) <> text "\">" else empty) $$
+ text "</OBJECT>") $+$
+ text "</LI>"
+ 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 "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML//EN\">" $$
+ text "<HTML>" $$
+ text "<HEAD>" $$
+ text "<META name=\"GENERATOR\" content=\"Haddock\">" $$
+ text "<!-- Sitemap 1.0 -->" $$
+ text "</HEAD><BODY>" $$
+ text "<UL>" $+$
+ nest 4 (ppList index) $+$
+ text "</UL>" $$
+ text "</BODY><HTML>"
+ 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 "<LI>" <> nest 4
+ (text "<OBJECT type=\"text/sitemap\">" $$
+ text "<PARAM name=\"Name\" value=\"" <> text (show name) <> text "\">" $$
+ text "<PARAM name=\"Local\" value=\"" <> text (moduleHtmlFile "" mod) <> char '#' <> text (show name) <> text "\">" $$
+ text "</OBJECT>") $+$
+ text "</LI>" $$
+ 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. |