diff options
Diffstat (limited to 'haddock-api/src/Haddock/Backends/Xhtml.hs')
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml.hs | 687 |
1 files changed, 687 insertions, 0 deletions
diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs new file mode 100644 index 00000000..65a7e6c4 --- /dev/null +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -0,0 +1,687 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Backends.Html +-- Copyright : (c) Simon Marlow 2003-2006, +-- David Waern 2006-2009, +-- Mark Lentczner 2010, +-- Mateusz Kowalczyk 2013 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} +module Haddock.Backends.Xhtml ( + ppHtml, copyHtmlBits, + ppHtmlIndex, ppHtmlContents, +) where + + +import Prelude hiding (div) + +import Haddock.Backends.Xhtml.Decl +import Haddock.Backends.Xhtml.DocMarkup +import Haddock.Backends.Xhtml.Layout +import Haddock.Backends.Xhtml.Names +import Haddock.Backends.Xhtml.Themes +import Haddock.Backends.Xhtml.Types +import Haddock.Backends.Xhtml.Utils +import Haddock.ModuleTree +import Haddock.Types +import Haddock.Version +import Haddock.Utils +import Text.XHtml hiding ( name, title, p, quote ) +import Haddock.GhcUtils + +import Control.Monad ( when, unless ) +import Data.Char ( toUpper ) +import Data.Functor ( (<$>) ) +import Data.List ( sortBy, groupBy, intercalate, isPrefixOf ) +import Data.Maybe +import System.FilePath hiding ( (</>) ) +import System.Directory +import Data.Map ( Map ) +import qualified Data.Map as Map hiding ( Map ) +import qualified Data.Set as Set hiding ( Set ) +import Data.Function +import Data.Ord ( comparing ) + +import DynFlags (Language(..)) +import GHC hiding ( NoLink, moduleInfo ) +import Name +import Module + +-------------------------------------------------------------------------------- +-- * Generating HTML documentation +-------------------------------------------------------------------------------- + + +ppHtml :: DynFlags + -> String -- ^ Title + -> Maybe String -- ^ Package + -> [Interface] + -> FilePath -- ^ Destination directory + -> Maybe (MDoc GHC.RdrName) -- ^ Prologue text, maybe + -> Themes -- ^ Themes + -> SourceURLs -- ^ The source URL (--source) + -> WikiURLs -- ^ The wiki URL (--wiki) + -> Maybe String -- ^ The contents URL (--use-contents) + -> Maybe String -- ^ The index URL (--use-index) + -> Bool -- ^ Whether to use unicode in output (--use-unicode) + -> QualOption -- ^ How to qualify names + -> Bool -- ^ Output pretty html (newlines and indenting) + -> IO () + +ppHtml dflags doctitle maybe_package ifaces odir prologue + themes maybe_source_url maybe_wiki_url + maybe_contents_url maybe_index_url unicode + qual debug = do + let + visible_ifaces = filter visible ifaces + visible i = OptHide `notElem` ifaceOptions i + + when (isNothing maybe_contents_url) $ + ppHtmlContents dflags odir doctitle maybe_package + themes maybe_index_url maybe_source_url maybe_wiki_url + (map toInstalledIface visible_ifaces) + False -- we don't want to display the packages in a single-package contents + prologue debug (makeContentsQual qual) + + when (isNothing maybe_index_url) $ + ppHtmlIndex odir doctitle maybe_package + themes maybe_contents_url maybe_source_url maybe_wiki_url + (map toInstalledIface visible_ifaces) debug + + mapM_ (ppHtmlModule odir doctitle themes + maybe_source_url maybe_wiki_url + maybe_contents_url maybe_index_url unicode qual debug) visible_ifaces + + +copyHtmlBits :: FilePath -> FilePath -> Themes -> IO () +copyHtmlBits odir libdir themes = do + let + libhtmldir = joinPath [libdir, "html"] + copyCssFile f = copyFile f (combine odir (takeFileName f)) + copyLibFile f = copyFile (joinPath [libhtmldir, f]) (joinPath [odir, f]) + mapM_ copyCssFile (cssFiles themes) + mapM_ copyLibFile [ jsFile, framesFile ] + + +headHtml :: String -> Maybe String -> Themes -> Html +headHtml docTitle miniPage themes = + header << [ + meta ! [httpequiv "Content-Type", content "text/html; charset=UTF-8"], + thetitle << docTitle, + styleSheet themes, + script ! [src jsFile, thetype "text/javascript"] << noHtml, + script ! [thetype "text/javascript"] + -- NB: Within XHTML, the content of script tags needs to be + -- a <![CDATA[ section. Will break if the miniPage name could + -- have "]]>" in it! + << primHtml ( + "//<![CDATA[\nwindow.onload = function () {pageLoad();" + ++ setSynopsis ++ "};\n//]]>\n") + ] + where + setSynopsis = maybe "" (\p -> "setSynopsis(\"" ++ p ++ "\");") miniPage + + +srcButton :: SourceURLs -> Maybe Interface -> Maybe Html +srcButton (Just src_base_url, _, _, _) Nothing = + Just (anchor ! [href src_base_url] << "Source") +srcButton (_, Just src_module_url, _, _) (Just iface) = + let url = spliceURL (Just $ ifaceOrigFilename iface) + (Just $ ifaceMod iface) Nothing Nothing src_module_url + in Just (anchor ! [href url] << "Source") +srcButton _ _ = + Nothing + + +wikiButton :: WikiURLs -> Maybe Module -> Maybe Html +wikiButton (Just wiki_base_url, _, _) Nothing = + Just (anchor ! [href wiki_base_url] << "User Comments") + +wikiButton (_, Just wiki_module_url, _) (Just mdl) = + let url = spliceURL Nothing (Just mdl) Nothing Nothing wiki_module_url + in Just (anchor ! [href url] << "User Comments") + +wikiButton _ _ = + Nothing + + +contentsButton :: Maybe String -> Maybe Html +contentsButton maybe_contents_url + = Just (anchor ! [href url] << "Contents") + where url = fromMaybe contentsHtmlFile maybe_contents_url + + +indexButton :: Maybe String -> Maybe Html +indexButton maybe_index_url + = Just (anchor ! [href url] << "Index") + where url = fromMaybe indexHtmlFile maybe_index_url + + +bodyHtml :: String -> Maybe Interface + -> SourceURLs -> WikiURLs + -> Maybe String -> Maybe String + -> Html -> Html +bodyHtml doctitle iface + maybe_source_url maybe_wiki_url + maybe_contents_url maybe_index_url + pageContent = + body << [ + divPackageHeader << [ + unordList (catMaybes [ + srcButton maybe_source_url iface, + wikiButton maybe_wiki_url (ifaceMod <$> iface), + contentsButton maybe_contents_url, + indexButton maybe_index_url]) + ! [theclass "links", identifier "page-menu"], + nonEmptySectionName << doctitle + ], + divContent << pageContent, + divFooter << paragraph << ( + "Produced by " +++ + (anchor ! [href projectUrl] << toHtml projectName) +++ + (" version " ++ projectVersion) + ) + ] + + +moduleInfo :: Interface -> Html +moduleInfo iface = + let + info = ifaceInfo iface + + doOneEntry :: (String, HaddockModInfo GHC.Name -> Maybe String) -> Maybe HtmlTable + doOneEntry (fieldName, field) = + field info >>= \a -> return (th << fieldName <-> td << a) + + entries :: [HtmlTable] + entries = mapMaybe doOneEntry [ + ("Copyright",hmi_copyright), + ("License",hmi_license), + ("Maintainer",hmi_maintainer), + ("Stability",hmi_stability), + ("Portability",hmi_portability), + ("Safe Haskell",hmi_safety), + ("Language", lg) + ] ++ extsForm + where + lg inf = case hmi_language inf of + Nothing -> Nothing + Just Haskell98 -> Just "Haskell98" + Just Haskell2010 -> Just "Haskell2010" + + extsForm + | OptShowExtensions `elem` ifaceOptions iface = + let fs = map (dropOpt . show) (hmi_extensions info) + in case map stringToHtml fs of + [] -> [] + [x] -> extField x -- don't use a list for a single extension + xs -> extField $ unordList xs ! [theclass "extension-list"] + | otherwise = [] + where + extField x = return $ th << "Extensions" <-> td << x + dropOpt x = if "Opt_" `isPrefixOf` x then drop 4 x else x + in + case entries of + [] -> noHtml + _ -> table ! [theclass "info"] << aboves entries + + +-------------------------------------------------------------------------------- +-- * Generate the module contents +-------------------------------------------------------------------------------- + + +ppHtmlContents + :: DynFlags + -> FilePath + -> String + -> Maybe String + -> Themes + -> Maybe String + -> SourceURLs + -> WikiURLs + -> [InstalledInterface] -> Bool -> Maybe (MDoc GHC.RdrName) + -> Bool + -> Qualification -- ^ How to qualify names + -> IO () +ppHtmlContents dflags odir doctitle _maybe_package + themes maybe_index_url + maybe_source_url maybe_wiki_url ifaces showPkgs prologue debug qual = do + let tree = mkModuleTree dflags showPkgs + [(instMod iface, toInstalledDescription iface) | iface <- ifaces] + html = + headHtml doctitle Nothing themes +++ + bodyHtml doctitle Nothing + maybe_source_url maybe_wiki_url + Nothing maybe_index_url << [ + ppPrologue qual doctitle prologue, + ppModuleTree qual tree + ] + createDirectoryIfMissing True odir + writeFile (joinPath [odir, contentsHtmlFile]) (renderToString debug html) + + -- XXX: think of a better place for this? + ppHtmlContentsFrame odir doctitle themes ifaces debug + + +ppPrologue :: Qualification -> String -> Maybe (MDoc GHC.RdrName) -> Html +ppPrologue _ _ Nothing = noHtml +ppPrologue qual title (Just doc) = + divDescription << (h1 << title +++ docElement thediv (rdrDocToHtml qual doc)) + + +ppModuleTree :: Qualification -> [ModuleTree] -> Html +ppModuleTree qual ts = + divModuleList << (sectionName << "Modules" +++ mkNodeList qual [] "n" ts) + + +mkNodeList :: Qualification -> [String] -> String -> [ModuleTree] -> Html +mkNodeList qual ss p ts = case ts of + [] -> noHtml + _ -> unordList (zipWith (mkNode qual ss) ps ts) + where + ps = [ p ++ '.' : show i | i <- [(1::Int)..]] + + +mkNode :: Qualification -> [String] -> String -> ModuleTree -> Html +mkNode qual ss p (Node s leaf pkg short ts) = + htmlModule <+> shortDescr +++ htmlPkg +++ subtree + where + modAttrs = case (ts, leaf) of + (_:_, False) -> collapseControl p True "module" + (_, _ ) -> [theclass "module"] + + cBtn = case (ts, leaf) of + (_:_, True) -> thespan ! collapseControl p True "" << spaceHtml + (_, _ ) -> noHtml + -- We only need an explicit collapser button when the module name + -- is also a leaf, and so is a link to a module page. Indeed, the + -- spaceHtml is a minor hack and does upset the layout a fraction. + + htmlModule = thespan ! modAttrs << (cBtn +++ + if leaf + then ppModule (mkModule (stringToPackageKey (fromMaybe "" pkg)) + (mkModuleName mdl)) + else toHtml s + ) + + mdl = intercalate "." (reverse (s:ss)) + + shortDescr = maybe noHtml (origDocToHtml qual) short + htmlPkg = maybe noHtml (thespan ! [theclass "package"] <<) pkg + + subtree = mkNodeList qual (s:ss) p ts ! collapseSection p True "" + + +-- | Turn a module tree into a flat list of full module names. E.g., +-- @ +-- A +-- +-B +-- +-C +-- @ +-- becomes +-- @["A", "A.B", "A.B.C"]@ +flatModuleTree :: [InstalledInterface] -> [Html] +flatModuleTree ifaces = + map (uncurry ppModule' . head) + . groupBy ((==) `on` fst) + . sortBy (comparing fst) + $ mods + where + mods = [ (moduleString mdl, mdl) | mdl <- map instMod ifaces ] + ppModule' txt mdl = + anchor ! [href (moduleHtmlFile mdl), target mainFrameName] + << toHtml txt + + +ppHtmlContentsFrame :: FilePath -> String -> Themes + -> [InstalledInterface] -> Bool -> IO () +ppHtmlContentsFrame odir doctitle themes ifaces debug = do + let mods = flatModuleTree ifaces + html = + headHtml doctitle Nothing themes +++ + miniBody << divModuleList << + (sectionName << "Modules" +++ + ulist << [ li ! [theclass "module"] << m | m <- mods ]) + createDirectoryIfMissing True odir + writeFile (joinPath [odir, frameIndexHtmlFile]) (renderToString debug html) + + +-------------------------------------------------------------------------------- +-- * Generate the index +-------------------------------------------------------------------------------- + + +ppHtmlIndex :: FilePath + -> String + -> Maybe String + -> Themes + -> Maybe String + -> SourceURLs + -> WikiURLs + -> [InstalledInterface] + -> Bool + -> IO () +ppHtmlIndex odir doctitle _maybe_package themes + maybe_contents_url maybe_source_url maybe_wiki_url ifaces debug = do + let html = indexPage split_indices Nothing + (if split_indices then [] else index) + + createDirectoryIfMissing True odir + + when split_indices $ do + mapM_ (do_sub_index index) initialChars + -- Let's add a single large index as well for those who don't know exactly what they're looking for: + let mergedhtml = indexPage False Nothing index + writeFile (joinPath [odir, subIndexHtmlFile merged_name]) (renderToString debug mergedhtml) + + writeFile (joinPath [odir, indexHtmlFile]) (renderToString debug html) + + where + indexPage showLetters ch items = + headHtml (doctitle ++ " (" ++ indexName ch ++ ")") Nothing themes +++ + bodyHtml doctitle Nothing + maybe_source_url maybe_wiki_url + maybe_contents_url Nothing << [ + if showLetters then indexInitialLetterLinks else noHtml, + if null items then noHtml else + divIndex << [sectionName << indexName ch, buildIndex items] + ] + + indexName ch = "Index" ++ maybe "" (\c -> " - " ++ [c]) ch + merged_name = "All" + + buildIndex items = table << aboves (map indexElt items) + + -- an arbitrary heuristic: + -- too large, and a single-page will be slow to load + -- too small, and we'll have lots of letter-indexes with only one + -- or two members in them, which seems inefficient or + -- unnecessarily hard to use. + split_indices = length index > 150 + + indexInitialLetterLinks = + divAlphabet << + unordList (map (\str -> anchor ! [href (subIndexHtmlFile str)] << str) $ + [ [c] | c <- initialChars + , any ((==c) . toUpper . head . fst) index ] ++ + [merged_name]) + + -- todo: what about names/operators that start with Unicode + -- characters? + -- Exports beginning with '_' can be listed near the end, + -- presumably they're not as important... but would be listed + -- with non-split index! + initialChars = [ 'A'..'Z' ] ++ ":!#$%&*+./<=>?@\\^|-~" ++ "_" + + do_sub_index this_ix c + = unless (null index_part) $ + writeFile (joinPath [odir, subIndexHtmlFile [c]]) (renderToString debug html) + where + html = indexPage True (Just c) index_part + index_part = [(n,stuff) | (n,stuff) <- this_ix, toUpper (head n) == c] + + + index :: [(String, Map GHC.Name [(Module,Bool)])] + index = sortBy cmp (Map.toAscList full_index) + where cmp (n1,_) (n2,_) = comparing (map toUpper) n1 n2 + + -- for each name (a plain string), we have a number of original HsNames that + -- it can refer to, and for each of those we have a list of modules + -- that export that entity. Each of the modules exports the entity + -- in a visible or invisible way (hence the Bool). + full_index :: Map String (Map GHC.Name [(Module,Bool)]) + full_index = Map.fromListWith (flip (Map.unionWith (++))) + (concatMap getIfaceIndex ifaces) + + getIfaceIndex iface = + [ (getOccString name + , Map.fromList [(name, [(mdl, name `Set.member` visible)])]) + | name <- instExports iface ] + where + mdl = instMod iface + visible = Set.fromList (instVisibleExports iface) + + indexElt :: (String, Map GHC.Name [(Module,Bool)]) -> HtmlTable + indexElt (str, entities) = + case Map.toAscList entities of + [(nm,entries)] -> + td ! [ theclass "src" ] << toHtml str <-> + indexLinks nm entries + many_entities -> + td ! [ theclass "src" ] << toHtml str <-> td << spaceHtml </> + aboves (zipWith (curry doAnnotatedEntity) [1..] many_entities) + + doAnnotatedEntity :: (Integer, (Name, [(Module, Bool)])) -> HtmlTable + doAnnotatedEntity (j,(nm,entries)) + = td ! [ theclass "alt" ] << + toHtml (show j) <+> parens (ppAnnot (nameOccName nm)) <-> + indexLinks nm entries + + ppAnnot n | not (isValOcc n) = toHtml "Type/Class" + | isDataOcc n = toHtml "Data Constructor" + | otherwise = toHtml "Function" + + indexLinks nm entries = + td ! [ theclass "module" ] << + hsep (punctuate comma + [ if visible then + linkId mdl (Just nm) << toHtml (moduleString mdl) + else + toHtml (moduleString mdl) + | (mdl, visible) <- entries ]) + + +-------------------------------------------------------------------------------- +-- * Generate the HTML page for a module +-------------------------------------------------------------------------------- + + +ppHtmlModule + :: FilePath -> String -> Themes + -> SourceURLs -> WikiURLs + -> Maybe String -> Maybe String -> Bool -> QualOption + -> Bool -> Interface -> IO () +ppHtmlModule odir doctitle themes + maybe_source_url maybe_wiki_url + maybe_contents_url maybe_index_url unicode qual debug iface = do + let + mdl = ifaceMod iface + aliases = ifaceModuleAliases iface + mdl_str = moduleString mdl + real_qual = makeModuleQual qual aliases mdl + html = + headHtml mdl_str (Just $ "mini_" ++ moduleHtmlFile mdl) themes +++ + bodyHtml doctitle (Just iface) + maybe_source_url maybe_wiki_url + maybe_contents_url maybe_index_url << [ + divModuleHeader << (moduleInfo iface +++ (sectionName << mdl_str)), + ifaceToHtml maybe_source_url maybe_wiki_url iface unicode real_qual + ] + + createDirectoryIfMissing True odir + writeFile (joinPath [odir, moduleHtmlFile mdl]) (renderToString debug html) + ppHtmlModuleMiniSynopsis odir doctitle themes iface unicode real_qual debug + +ppHtmlModuleMiniSynopsis :: FilePath -> String -> Themes + -> Interface -> Bool -> Qualification -> Bool -> IO () +ppHtmlModuleMiniSynopsis odir _doctitle themes iface unicode qual debug = do + let mdl = ifaceMod iface + html = + headHtml (moduleString mdl) Nothing themes +++ + miniBody << + (divModuleHeader << sectionName << moduleString mdl +++ + miniSynopsis mdl iface unicode qual) + createDirectoryIfMissing True odir + writeFile (joinPath [odir, "mini_" ++ moduleHtmlFile mdl]) (renderToString debug html) + + +ifaceToHtml :: SourceURLs -> WikiURLs -> Interface -> Bool -> Qualification -> Html +ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual + = ppModuleContents qual exports +++ + description +++ + synopsis +++ + divInterface (maybe_doc_hdr +++ bdy) + where + exports = numberSectionHeadings (ifaceRnExportItems iface) + + -- todo: if something has only sub-docs, or fn-args-docs, should + -- it be measured here and thus prevent omitting the synopsis? + has_doc ExportDecl { expItemMbDoc = (Documentation mDoc mWarning, _) } = isJust mDoc || isJust mWarning + has_doc (ExportNoDecl _ _) = False + has_doc (ExportModule _) = False + has_doc _ = True + + no_doc_at_all = not (any has_doc exports) + + description | isNoHtml doc = doc + | otherwise = divDescription $ sectionName << "Description" +++ doc + where doc = docSection Nothing qual (ifaceRnDoc iface) + + -- omit the synopsis if there are no documentation annotations at all + synopsis + | no_doc_at_all = noHtml + | otherwise + = divSynposis $ + paragraph ! collapseControl "syn" False "caption" << "Synopsis" +++ + shortDeclList ( + mapMaybe (processExport True linksInfo unicode qual) exports + ) ! (collapseSection "syn" False "" ++ collapseToggle "syn") + + -- if the documentation doesn't begin with a section header, then + -- add one ("Documentation"). + maybe_doc_hdr + = case exports of + [] -> noHtml + ExportGroup {} : _ -> noHtml + _ -> h1 << "Documentation" + + bdy = + foldr (+++) noHtml $ + mapMaybe (processExport False linksInfo unicode qual) exports + + linksInfo = (maybe_source_url, maybe_wiki_url) + + +miniSynopsis :: Module -> Interface -> Bool -> Qualification -> Html +miniSynopsis mdl iface unicode qual = + divInterface << concatMap (processForMiniSynopsis mdl unicode qual) exports + where + exports = numberSectionHeadings (ifaceRnExportItems iface) + + +processForMiniSynopsis :: Module -> Bool -> Qualification -> ExportItem DocName + -> [Html] +processForMiniSynopsis mdl unicode qual ExportDecl { expItemDecl = L _loc decl0 } = + ((divTopDecl <<).(declElem <<)) <$> case decl0 of + TyClD d -> let b = ppTyClBinderWithVarsMini mdl d in case d of + (FamDecl decl) -> [ppTyFamHeader True False decl unicode qual] + (DataDecl{}) -> [keyword "data" <+> b] + (SynDecl{}) -> [keyword "type" <+> b] + (ClassDecl {}) -> [keyword "class" <+> b] + SigD (TypeSig lnames (L _ _) _) -> + map (ppNameMini Prefix mdl . nameOccName . getName . unLoc) lnames + _ -> [] +processForMiniSynopsis _ _ qual (ExportGroup lvl _id txt) = + [groupTag lvl << docToHtml Nothing qual (mkMeta txt)] +processForMiniSynopsis _ _ _ _ = [] + + +ppNameMini :: Notation -> Module -> OccName -> Html +ppNameMini notation mdl nm = + anchor ! [ href (moduleNameUrl mdl nm) + , target mainFrameName ] + << ppBinder' notation nm + + +ppTyClBinderWithVarsMini :: Module -> TyClDecl DocName -> Html +ppTyClBinderWithVarsMini mdl decl = + let n = tcdName decl + ns = tyvarNames $ tcdTyVars decl -- it's safe to use tcdTyVars, see code above + in ppTypeApp n [] ns (\is_infix -> ppNameMini is_infix mdl . nameOccName . getName) ppTyName + +ppModuleContents :: Qualification -> [ExportItem DocName] -> Html +ppModuleContents qual exports + | null sections = noHtml + | otherwise = contentsDiv + where + contentsDiv = divTableOfContents << ( + sectionName << "Contents" +++ + unordList sections) + + (sections, _leftovers{-should be []-}) = process 0 exports + + process :: Int -> [ExportItem DocName] -> ([Html],[ExportItem DocName]) + process _ [] = ([], []) + process n items@(ExportGroup lev id0 doc : rest) + | lev <= n = ( [], items ) + | otherwise = ( html:secs, rest2 ) + where + html = linkedAnchor (groupId id0) + << docToHtmlNoAnchors (Just id0) qual (mkMeta doc) +++ mk_subsections ssecs + (ssecs, rest1) = process lev rest + (secs, rest2) = process n rest1 + process n (_ : rest) = process n rest + + mk_subsections [] = noHtml + mk_subsections ss = unordList ss + +-- we need to assign a unique id to each section heading so we can hyperlink +-- them from the contents: +numberSectionHeadings :: [ExportItem DocName] -> [ExportItem DocName] +numberSectionHeadings = go 1 + where go :: Int -> [ExportItem DocName] -> [ExportItem DocName] + go _ [] = [] + go n (ExportGroup lev _ doc : es) + = ExportGroup lev (show n) doc : go (n+1) es + go n (other:es) + = other : go n es + + +processExport :: Bool -> LinksInfo -> Bool -> Qualification + -> ExportItem DocName -> Maybe Html +processExport _ _ _ _ ExportDecl { expItemDecl = L _ (InstD _) } = Nothing -- Hide empty instances +processExport summary _ _ qual (ExportGroup lev id0 doc) + = nothingIf summary $ groupHeading lev id0 << docToHtml (Just id0) qual (mkMeta doc) +processExport summary links unicode qual (ExportDecl decl doc subdocs insts fixities splice) + = processDecl summary $ ppDecl summary links decl doc insts fixities subdocs splice unicode qual +processExport summary _ _ qual (ExportNoDecl y []) + = processDeclOneLiner summary $ ppDocName qual Prefix True y +processExport summary _ _ qual (ExportNoDecl y subs) + = processDeclOneLiner summary $ + ppDocName qual Prefix True y + +++ parenList (map (ppDocName qual Prefix True) subs) +processExport summary _ _ qual (ExportDoc doc) + = nothingIf summary $ docSection_ Nothing qual doc +processExport summary _ _ _ (ExportModule mdl) + = processDeclOneLiner summary $ toHtml "module" <+> ppModule mdl + + +nothingIf :: Bool -> a -> Maybe a +nothingIf True _ = Nothing +nothingIf False a = Just a + + +processDecl :: Bool -> Html -> Maybe Html +processDecl True = Just +processDecl False = Just . divTopDecl + + +processDeclOneLiner :: Bool -> Html -> Maybe Html +processDeclOneLiner True = Just +processDeclOneLiner False = Just . divTopDecl . declElem + +groupHeading :: Int -> String -> Html -> Html +groupHeading lev id0 = groupTag lev ! [identifier (groupId id0)] + +groupTag :: Int -> Html -> Html +groupTag lev + | lev == 1 = h1 + | lev == 2 = h2 + | lev == 3 = h3 + | otherwise = h4 |