module HaddockHH(ppHHContents, ppHHIndex, ppHHProject) where import HsSyn hiding(Doc) #if __GLASGOW_HASKELL__ < 503 import Pretty import FiniteMap #else import Text.PrettyPrint import Data.FiniteMap import Data.Char #endif import Maybe ( fromMaybe ) import HaddockModuleTree import HaddockUtil import HaddockTypes 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 -> [(Module,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 = fmToList (foldr getIfaceIndex emptyFM ifaces) getIfaceIndex (mdl,iface) fm = addListToFM_C (++) fm [(name, [mdl]) | (name, Qual mdl' _) <- fmToList (iface_env iface), mdl == mdl'] 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 -> [(Module,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 ((Module mdl,_):ifaces) = 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 = keysFM (foldr getIfaceIndex emptyFM ifaces) getIfaceIndex (mdl,iface) fm = addListToFM fm [(toUpper (head (show name)),()) | (name, Qual mdl' _) <- fmToList (iface_env iface), mdl == mdl']