From 11ebf08d5ef30375ba5585b6079f696d49402c3f Mon Sep 17 00:00:00 2001 From: "davve@dtek.chalmers.se" Date: Sun, 25 Mar 2007 01:23:25 +0000 Subject: De-flatten the namespace --- src/Haddock/HH2.hs | 182 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 182 insertions(+) create mode 100644 src/Haddock/HH2.hs (limited to 'src/Haddock/HH2.hs') diff --git a/src/Haddock/HH2.hs b/src/Haddock/HH2.hs new file mode 100644 index 00000000..945734e6 --- /dev/null +++ b/src/Haddock/HH2.hs @@ -0,0 +1,182 @@ +module Haddock.HH2(ppHH2Contents, ppHH2Index, ppHH2Files, ppHH2Collection) where + +ppHH2Contents = error "not yet" +ppHH2Index = error "not yet" +ppHH2Files = error "not yet" +ppHH2Collection = 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 + +ppHH2Contents :: FilePath -> String -> Maybe String -> [ModuleTree] -> IO () +ppHH2Contents odir doctitle maybe_package tree = do + let + contentsHH2File = package++".HxT" + + doc = + text "" $$ + text "" $$ + text "" $$ + nest 4 (text "text doctitle<>text"\" Url=\"index.html\">" $$ + nest 4 (ppModuleTree [] tree) $+$ + text "") $$ + text "" + writeFile (pathJoin [odir, contentsHH2File]) (render doc) + where + package = fromMaybe "pkg" maybe_package + + ppModuleTree :: [String] -> [ModuleTree] -> Doc + ppModuleTree ss [x] = ppNode ss x + ppModuleTree ss (x:xs) = ppNode ss x $$ ppModuleTree ss xs + ppModuleTree _ [] = error "HaddockHH2.ppHH2Contents.ppModuleTree: no module trees given" + + ppNode :: [String] -> ModuleTree -> Doc + ppNode ss (Node s leaf _pkg _short []) = + text " ppAttributes leaf (s:ss) <> text "/>" + ppNode ss (Node s leaf _pkg _short ts) = + text " ppAttributes leaf (s:ss) <> text ">" $$ + nest 4 (ppModuleTree (s:ss) ts) $+$ + text "" + + ppAttributes :: Bool -> [String] -> Doc + ppAttributes isleaf ss = hsep [ppId,ppTitle,ppUrl] + where + mdl = foldr (++) "" (s' : map ('.':) ss') + (s':ss') = reverse ss + -- reconstruct the module name + + ppId = text "Id=" <> doubleQuotes (text mdl) + + ppTitle = text "Title=" <> doubleQuotes (text (head ss)) + + ppUrl | isleaf = text " Url=" <> doubleQuotes (text (moduleHtmlFile mdl)) + | otherwise = empty + +----------------------------------------------------------------------------------- + +ppHH2Index :: FilePath -> Maybe String -> [Interface] -> IO () +ppHH2Index odir maybe_package ifaces = do + let + indexKHH2File = package++"K.HxK" + indexNHH2File = package++"N.HxK" + docK = + text "" $$ + text "" $$ + text "" $$ + nest 4 (ppList index) $+$ + text "" + docN = + text "" $$ + text "" $$ + text "" $$ + text "" $$ + nest 4 (text "text contentsHtmlFile<>text "\"/>") $$ + text "" $$ + text "" + writeFile (pathJoin [odir, indexKHH2File]) (render docK) + writeFile (pathJoin [odir, indexNHH2File]) (render docN) + where + package = fromMaybe "pkg" maybe_package + + index :: [(HsName, [Module])] + index = Map.toAscList (foldr getIfaceIndex Map.empty ifaces) + + getIfaceIndex iface fm = + Map.unionWith (++) (Map.fromListWith (flip (++)) [(name, [mdl]) | (name, Qual mdl' _) <- Map.toAscList (iface_env iface), mdl == mdl']) fm + where mdl = iface_module iface + + ppList [] = empty + ppList ((name,mdls):vs) = + text " text (escapeStr (show name)) <> text "\">" $$ + nest 4 (vcat (map (ppJump name) mdls)) $$ + text "" $$ + ppList vs + + ppJump name (Module mdl) = text " text (nameHtmlRef mdl name) <> text "\"/>" + + +----------------------------------------------------------------------------------- + +ppHH2Files :: FilePath -> Maybe String -> [Interface] -> [FilePath] -> IO () +ppHH2Files odir maybe_package ifaces pkg_paths = do + let filesHH2File = package++".HxF" + doc = + text "" $$ + text "" $$ + text "" $$ + nest 4 (ppMods ifaces $$ + text "text contentsHtmlFile<>text "\"/>" $$ + text "text indexHtmlFile<>text "\"/>" $$ + ppIndexFiles chars $$ + ppLibFiles ("":pkg_paths)) $$ + text "" + writeFile (pathJoin [odir, filesHH2File]) (render doc) + where + package = fromMaybe "pkg" maybe_package + + ppMods [] = empty + ppMods (iface:ifaces) = + text " text (moduleHtmlFile mdl) <> text "\"/>" $$ + ppMods ifaces + where Module mdl = iface_module iface + + ppIndexFiles [] = empty + ppIndexFiles (c:cs) = + text "text (subIndexHtmlFile c)<>text "\"/>" $$ + 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 "text (toPath fname)<>text "\"/>" + + 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 + +----------------------------------------------------------------------------------- + +ppHH2Collection :: FilePath -> String -> Maybe String -> IO () +ppHH2Collection odir doctitle maybe_package = do + let + package = fromMaybe "pkg" maybe_package + collectionHH2File = package++".HxC" + + doc = + text "" $$ + text "" $$ + text " text doctitle <> text "\">" $$ + nest 4 (text "" $$ + nest 4 (text " text package <> text ".HxF\"/>") $$ + text "" $$ + text " text package <> text ".HxT\"/>" $$ + text " text package <> text "K.HxK\"/>" $$ + text " text package <> text "N.HxK\"/>" $$ + text "" $$ + text "" $$ + text "" $$ + text "" $$ + text "" $$ + text "") $$ + text "" + writeFile (pathJoin [odir, collectionHH2File]) (render doc) +-} -- cgit v1.2.3