|
|
--
-- Haddock - A Haskell Documentation Tool
--
-- (c) Simon Marlow 2003
--
module Haddock.Backends.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 "<?xml version=\"1.0\"?>" $$
text "<!DOCTYPE HelpTOC SYSTEM \"ms-help://hx/resources/HelpTOC.DTD\">" $$
text "<HelpTOC DTDVersion=\"1.0\">" $$
nest 4 (text "<HelpTOCNode Title=\""<>text doctitle<>text"\" Url=\"index.html\">" $$
nest 4 (ppModuleTree [] tree) $+$
text "</HelpTOCNode>") $$
text "</HelpTOC>"
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 "<HelpTOCNode" <+> ppAttributes leaf (s:ss) <> text "/>"
ppNode ss (Node s leaf _pkg _short ts) =
text "<HelpTOCNode" <+> ppAttributes leaf (s:ss) <> text ">" $$
nest 4 (ppModuleTree (s:ss) ts) $+$
text "</HelpTOCNode>"
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 "<?xml version=\"1.0\"?>" $$
text "<!DOCTYPE HelpIndex SYSTEM \"ms-help://hx/resources/HelpIndex.DTD\">" $$
text "<HelpIndex DTDVersion=\"1.0\" Name=\"K\">" $$
nest 4 (ppList index) $+$
text "</HelpIndex>"
docN =
text "<?xml version=\"1.0\"?>" $$
text "<!DOCTYPE HelpIndex SYSTEM \"ms-help://hx/resources/HelpIndex.DTD\">" $$
text "<HelpIndex DTDVersion=\"1.0\" Name=\"NamedURLIndex\">" $$
text "<Keyword Term=\"HomePage\">" $$
nest 4 (text "<Jump Url=\""<>text contentsHtmlFile<>text "\"/>") $$
text "</Keyword>" $$
text "</HelpIndex>"
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 "<Keyword Term=\"" <> text (escapeStr (show name)) <> text "\">" $$
nest 4 (vcat (map (ppJump name) mdls)) $$
text "</Keyword>" $$
ppList vs
ppJump name (Module mdl) = text "<Jump Url=\"" <> 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 "<?xml version=\"1.0\"?>" $$
text "<!DOCTYPE HelpFileList SYSTEM \"ms-help://hx/resources/HelpFileList.DTD\">" $$
text "<HelpFileList DTDVersion=\"1.0\">" $$
nest 4 (ppMods ifaces $$
text "<File Url=\""<>text contentsHtmlFile<>text "\"/>" $$
text "<File Url=\""<>text indexHtmlFile<>text "\"/>" $$
ppIndexFiles chars $$
ppLibFiles ("":pkg_paths)) $$
text "</HelpFileList>"
writeFile (pathJoin [odir, filesHH2File]) (render doc)
where
package = fromMaybe "pkg" maybe_package
ppMods [] = empty
ppMods (iface:ifaces) =
text "<File Url=\"" <> text (moduleHtmlFile mdl) <> text "\"/>" $$
ppMods ifaces
where Module mdl = iface_module iface
ppIndexFiles [] = empty
ppIndexFiles (c:cs) =
text "<File Url=\""<>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 "<File Url=\""<>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 "<?xml version=\"1.0\"?>" $$
text "<!DOCTYPE HelpCollection SYSTEM \"ms-help://hx/resources/HelpCollection.DTD\">" $$
text "<HelpCollection DTDVersion=\"1.0\" LangId=\"1033\" Title=\"" <> text doctitle <> text "\">" $$
nest 4 (text "<CompilerOptions CreateFullTextIndex=\"Yes\">" $$
nest 4 (text "<IncludeFile File=\"" <> text package <> text ".HxF\"/>") $$
text "</CompilerOptions>" $$
text "<TOCDef File=\"" <> text package <> text ".HxT\"/>" $$
text "<KeywordIndexDef File=\"" <> text package <> text "K.HxK\"/>" $$
text "<KeywordIndexDef File=\"" <> text package <> text "N.HxK\"/>" $$
text "<ItemMoniker Name=\"!DefaultToc\" ProgId=\"HxDs.HxHierarchy\" InitData=\"\"/>" $$
text "<ItemMoniker Name=\"!DefaultFullTextSearch\" ProgId=\"HxDs.HxFullTextSearch\" InitData=\"\"/>" $$
text "<ItemMoniker Name=\"!DefaultAssociativeIndex\" ProgId=\"HxDs.HxIndex\" InitData=\"A\"/>" $$
text "<ItemMoniker Name=\"!DefaultKeywordIndex\" ProgId=\"HxDs.HxIndex\" InitData=\"K\"/>" $$
text "<ItemMoniker Name=\"!DefaultNamedUrlIndex\" ProgId=\"HxDs.HxIndex\" InitData=\"NamedURLIndex\"/>" $$
text "<ItemMoniker Name=\"!SampleInfo\" ProgId=\"HxDs.HxSampleCollection\" InitData=\"\"/>") $$
text "</HelpCollection>"
writeFile (pathJoin [odir, collectionHH2File]) (render doc)
-}
|