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 "" $$
text "" $$
text "" $$
text "" $$
text "" $$
text "" $$
ppModuleTree tree $$
text ""
writeFile (pathJoin [odir, contentsHHFile]) (render html)
where
package = fromMaybe "pkg" maybe_package
ppModuleTree :: [ModuleTree] -> Doc
ppModuleTree ts =
text "" $$
text "
" $+$
nest 4 (text "
" <> nest 4
(text "") $+$
text "
" $$
text "
" $+$
nest 4 (fn [] ts) $+$
text "
") $+$
text "
"
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 "
" $+$
nest 4 (fn (s:ss) ts) $+$
text "
"
ppLeaf s ss isleaf =
text "
" <> nest 4
(text "") $+$
text "
"
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 "" $$
text "" $$
text "" $$
text "" $$
text "" $$
text "" $$
text "
" $+$
nest 4 (ppList index) $+$
text "
" $$
text ""
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 "
" <> nest 4
(text "") $+$
text "
" $$
ppList mdls
ppReference name [] = empty
ppReference name (Module mdl:refs) =
text " 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']