diff options
Diffstat (limited to 'src/HaddockHH2.hs')
| -rw-r--r-- | src/HaddockHH2.hs | 162 |
1 files changed, 162 insertions, 0 deletions
diff --git a/src/HaddockHH2.hs b/src/HaddockHH2.hs new file mode 100644 index 00000000..bb291bd7 --- /dev/null +++ b/src/HaddockHH2.hs @@ -0,0 +1,162 @@ +module HaddockHH2(ppHH2Contents, ppHH2Index, ppHH2Files, ppHH2Collection) where + +import HsSyn hiding(Doc) + +#if __GLASGOW_HASKELL__ < 503 +import Pretty +import FiniteMap +#else +import Text.PrettyPrint +import Data.FiniteMap +import Data.List +import Data.Char +#endif + +import HaddockModuleTree +import HaddockUtil +import HaddockTypes + +ppHH2Contents :: FilePath -> String -> [(Module,Interface)] -> IO () +ppHH2Contents odir package ifaces = do + let + contentsHH2File = package++".HxT" + + tree = mkModuleTree (map (\(mod,_) -> (mod,Nothing)) ifaces) --TODO: packages + doc = + text "<?xml version=\"1.0\"?>" $$
+ text "<!DOCTYPE HelpTOC SYSTEM \"ms-help://hx/resources/HelpTOC.DTD\">" $$ + text "<HelpTOC DTDVersion=\"1.0\">" $$ + nest 4 (ppModuleTree [] tree) $$ + text "</HelpTOC>" + writeFile (odir ++ pathSeparator:contentsHH2File) (render doc) + where + 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 []) = + text "<HelpTOCNode" <+> ppAttributes leaf (s:ss) <> text "/>" + ppNode ss (Node s leaf _pkg 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 -> String -> [(Module,Interface)] -> IO () +ppHH2Index odir 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=\"index.html\"/>") $$
+ text "</Keyword>" $$
+ text "</HelpIndex>" + writeFile (odir ++ pathSeparator:indexKHH2File) (render docK) + writeFile (odir ++ pathSeparator:indexNHH2File) (render docN) + where + 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,mdls):vs) = + text "<Keyword Term=\"" <> text (show name) <> text "\">" $$
+ nest 4 (vcat (map (ppJump name) mdls)) $$
+ text "</Keyword>" $$
+ ppList vs + + ppJump name (Module mdl) = text "<Jump Url=\"" <> text (nameHtmlRef fp mdl name) <> text "\"/>" + where + fp = case lookupFM html_xrefs (Module mdl) of + Nothing -> "" + Just fp0 -> fp0 + + +----------------------------------------------------------------------------------- + +ppHH2Files :: FilePath -> String -> [(Module,Interface)] -> IO () +ppHH2Files odir package ifaces = 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=\"index.html\"/>" $$
+ text "<File Url=\"doc-index.html\"/>" $$
+ ppIndexFiles chars $$
+ text "<File Url=\""<>text iconFile<>text "\"/>" $$
+ text "<File Url=\""<>text cssFile<>text "\"/>") $$
+ text "</HelpFileList>"
+ writeFile (odir ++ pathSeparator:filesHH2File) (render doc) + where + ppMods [] = empty + ppMods ((Module mdl,_):ifaces) = + text "<File Url=\"" <> text (moduleHtmlFile "" mdl) <> text "\"/>" $$
+ ppMods ifaces + + ppIndexFiles [] = empty + ppIndexFiles (c:cs) = + text "<File Url=\"doc-index-" <> char c <> text ".html\"/>" $$
+ ppIndexFiles cs + + 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'] + +----------------------------------------------------------------------------------- + +ppHH2Collection :: FilePath -> String -> [(Module,Interface)] -> IO () +ppHH2Collection odir package ifaces = do + let + 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 package <> 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 (odir ++ pathSeparator:collectionHH2File) (render doc) |