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 -> Maybe String -> [ModuleTree] -> IO () ppHHContents odir maybe_package tree = do let contentsHHFile = package++".hhc" html = text "" $$ text "" $$ text "" $$ text "" $$ text "" $$ text "" $$ ppModuleTree tree $$ text "" writeFile (odir ++ pathSeparator:contentsHHFile) (render html) where package = fromMaybe "pkg" maybe_package ppModuleTree :: [ModuleTree] -> Doc ppModuleTree ts = text "" $$ text "" $$ 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 "" ppLeaf s ss isleaf = text "
  • " <> nest 4 (text "" $$ text " text s <> text "\">" $$ (if isleaf then text " text (moduleHtmlFile mdl) <> text "\">" else empty) $$ 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 "" $$ text "" writeFile (odir ++ pathSeparator: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 " text (show name) <> text "\">" $$ ppReference name refs $$ 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 (odir ++ pathSeparator: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 = path++pathSeparator: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']