module HaddockHH(ppHHContents, ppHHIndex) where
import HsSyn hiding(Doc)
#if __GLASGOW_HASKELL__ < 503
import Pretty
import FiniteMap
#else
import Text.PrettyPrint
import Data.FiniteMap
#endif
import HaddockModuleTree
import HaddockUtil
import HaddockTypes
contentsHHFile, indexHHFile :: String
contentsHHFile = "index.hhc"
indexHHFile = "index.hhk"
ppHHContents :: FilePath -> [(Module,Interface)] -> IO ()
ppHHContents odir ifaces = do
let tree = mkModuleTree (map (\(mod,_) -> (mod,Nothing)) ifaces) --TODO: packages
html =
text "" $$
text "" $$
text "" $$
text "" $$
text "" $$
text "" $$
ppModuleTree tree $$
text ""
writeFile (odir ++ pathSeparator:contentsHHFile) (render html)
where
ppModuleTree :: [ModuleTree] -> Doc
ppModuleTree ts =
text "" $$
text "
" $+$
nest 4 (fn [] ts) $+$
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 -> [(Module,Interface)] -> IO ()
ppHHIndex odir ifaces = do
let html =
text "" $$
text "" $$
text "" $$
text "" $$
text "" $$
text "" $$
text "
" $+$
nest 4 (ppList index) $+$
text "
" $$
text ""
writeFile (odir ++ pathSeparator:indexHHFile) (render html)
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,(Module mdl:_)):mdls) =
text "