diff options
| author | davve@dtek.chalmers.se <David Waern> | 2007-03-25 01:23:25 +0000 |
|---|---|---|
| committer | davve@dtek.chalmers.se <David Waern> | 2007-03-25 01:23:25 +0000 |
| commit | 11ebf08d5ef30375ba5585b6079f696d49402c3f (patch) | |
| tree | 0287ff78e5f7f0658010c6c18993415693bd9ab9 /src/Haddock/HH.hs | |
| parent | bc59490468c17bfc181ffe51cf428314195ad8a0 (diff) | |
De-flatten the namespace
Diffstat (limited to 'src/Haddock/HH.hs')
| -rw-r--r-- | src/Haddock/HH.hs | 174 |
1 files changed, 174 insertions, 0 deletions
diff --git a/src/Haddock/HH.hs b/src/Haddock/HH.hs new file mode 100644 index 00000000..a41d7297 --- /dev/null +++ b/src/Haddock/HH.hs @@ -0,0 +1,174 @@ +module Haddock.HH(ppHHContents, ppHHIndex, ppHHProject) where + +ppHHContents = error "not yet" +ppHHIndex = error "not yet" +ppHHProject = error "not yet" + +{- +import HaddockModuleTree +import HaddockTypes +import HaddockUtil +import HsSyn2 hiding(Doc) +import qualified Map + +import Data.Char ( toUpper ) +import Data.Maybe ( fromMaybe ) +import Text.PrettyPrint + +ppHHContents :: FilePath -> String -> Maybe String -> [ModuleTree] -> IO () +ppHHContents odir doctitle maybe_package tree = do + let contentsHHFile = package++".hhc" + + 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 (pathJoin [odir, contentsHHFile]) (render html) + where + package = fromMaybe "pkg" maybe_package + + ppModuleTree :: [ModuleTree] -> Doc + ppModuleTree ts = + text "<OBJECT type=\"text/site properties\">" $$ + text "<PARAM name=\"FrameName\" value=\"main\">" $$ + text "</OBJECT>" $$ + text "<UL>" $+$ + nest 4 (text "<LI>" <> nest 4 + (text "<OBJECT type=\"text/sitemap\">" $$ + nest 4 (text "<PARAM name=\"Name\" value=\""<>text doctitle<>text "\">" $$ + text "<PARAM name=\"Local\" value=\"index.html\">") $$ + text "</OBJECT>") $+$ + text "</LI>" $$ + text "<UL>" $+$ + nest 4 (fn [] ts) $+$ + text "</UL>") $+$ + text "</UL>" + + fn :: [String] -> [ModuleTree] -> Doc + fn ss [x] = ppNode ss x + fn ss (x:xs) = ppNode ss x $$ fn ss xs + fn _ [] = error "HaddockHH.ppHHContents.fn: no module trees given" + + ppNode :: [String] -> ModuleTree -> Doc + ppNode ss (Node s leaf _pkg _ []) = + ppLeaf s ss leaf + ppNode ss (Node s leaf _pkg _ 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 mdl) <> text "\">" else empty) $$ + text "</OBJECT>") $+$ + text "</LI>" + where + mdl = foldr (++) "" (s' : map ('.':) ss') + (s':ss') = reverse (s:ss) + -- reconstruct the module name + +------------------------------- +ppHHIndex :: FilePath -> Maybe String -> [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>" $$ + 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 (pathJoin [odir, indexHHFile]) (render html) + where + package = fromMaybe "pkg" maybe_package + + index :: [(HsName, [Module])] + index = Map.toAscList (foldr getIfaceIndex Map.empty ifaces) + + getIfaceIndex iface fm = + foldl (\m (k,e) -> Map.insertWith (++) k e m) fm [(name, [mdl]) | (name, Qual mdl' _) <- Map.toAscList (iface_env iface), mdl == mdl'] + where mdl = iface_module iface + + ppList [] = empty + ppList ((name,refs):mdls) = + text "<LI>" <> nest 4 + (text "<OBJECT type=\"text/sitemap\">" $$ + text "<PARAM name=\"Name\" value=\"" <> text (show 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 -> [Interface] -> [FilePath] -> IO () +ppHHProject odir doctitle maybe_package ifaces pkg_paths = 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 $$ + ppLibFiles ("":pkg_paths) + writeFile (pathJoin [odir, projectHHFile]) (render doc) + where + package = fromMaybe "pkg" maybe_package + + ppMods [] = empty + ppMods (iface:ifaces) = + let Module mdl = iface_module iface in + text (moduleHtmlFile mdl) $$ + ppMods ifaces + + ppIndexFiles [] = empty + ppIndexFiles (c:cs) = + text (subIndexHtmlFile c) $$ + ppIndexFiles cs + + ppLibFiles [] = empty + ppLibFiles (path:paths) = + ppLibFile cssFile $$ + ppLibFile iconFile $$ + ppLibFile jsFile $$ + ppLibFile plusFile $$ + ppLibFile minusFile $$ + ppLibFiles paths + where + toPath fname | null path = fname + | otherwise = pathJoin [path, fname] + ppLibFile fname = text (toPath fname) + + chars :: [Char] + chars = map fst (Map.toAscList (foldr getIfaceIndex Map.empty ifaces)) + + getIfaceIndex iface fm = + Map.union (Map.fromList [(toUpper (head (show name)),()) | (name, Qual mdl' _) <- Map.toAscList (iface_env iface), mdl == mdl']) fm + where mdl = iface_module iface +-} |