diff options
Diffstat (limited to 'src/Haddock/Backends')
| -rw-r--r-- | src/Haddock/Backends/Xhtml.hs | 758 | ||||
| -rw-r--r-- | src/Haddock/Backends/Xhtml/Decl.hs | 874 | ||||
| -rw-r--r-- | src/Haddock/Backends/Xhtml/DocMarkup.hs | 99 | ||||
| -rw-r--r-- | src/Haddock/Backends/Xhtml/Layout.hs | 127 | ||||
| -rw-r--r-- | src/Haddock/Backends/Xhtml/Names.hs | 76 | ||||
| -rw-r--r-- | src/Haddock/Backends/Xhtml/Types.hs | 22 | ||||
| -rw-r--r-- | src/Haddock/Backends/Xhtml/Util.hs | 203 |
7 files changed, 2159 insertions, 0 deletions
diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs new file mode 100644 index 00000000..630a603e --- /dev/null +++ b/src/Haddock/Backends/Xhtml.hs @@ -0,0 +1,758 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Backends.Html +-- Copyright : (c) Simon Marlow 2003-2006, +-- David Waern 2006-2009, +-- Mark Lentczner 2010 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- + +module Haddock.Backends.Xhtml ( + ppHtml, copyHtmlBits, + ppHtmlIndex, ppHtmlContents, + ppHtmlHelpFiles +) where + + +import Prelude hiding (div) + +import Haddock.Backends.DevHelp +import Haddock.Backends.HH +import Haddock.Backends.HH2 +import Haddock.Backends.Xhtml.Decl +import Haddock.Backends.Xhtml.DocMarkup +import Haddock.Backends.Xhtml.Layout +import Haddock.Backends.Xhtml.Names +import Haddock.Backends.Xhtml.Types +import Haddock.Backends.Xhtml.Util +import Haddock.ModuleTree +import Haddock.Types +import Haddock.Version +import Haddock.Utils +import Text.XHtml hiding ( name, title, p, quote ) +import qualified Text.XHtml as Html +import Haddock.GhcUtils + +import Control.Exception ( bracket ) +import Control.Monad ( when, unless ) +import Control.Monad.Instances ( ) -- for Functor Either a +import Data.Char ( toUpper ) +import Data.Either +import Data.List ( sortBy, groupBy ) +import Data.Maybe +import Foreign.Marshal.Alloc ( allocaBytes ) +import System.IO ( IOMode(..), hClose, hGetBuf, hPutBuf, openFile ) +import System.Directory hiding ( copyFile ) +import Data.Map ( Map ) +import qualified Data.Map as Map hiding ( Map ) +import Data.Function +import Data.Ord ( comparing ) + +import GHC hiding ( NoLink, moduleInfo ) +import Name +import Module + + + +-- ----------------------------------------------------------------------------- +-- Generating HTML documentation + +ppHtml :: String + -> Maybe String -- package + -> [Interface] + -> FilePath -- destination directory + -> Maybe (Doc GHC.RdrName) -- prologue text, maybe + -> Maybe String -- the Html Help format (--html-help) + -> 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) + -> IO () + +ppHtml doctitle maybe_package ifaces odir prologue maybe_html_help_format + maybe_source_url maybe_wiki_url + maybe_contents_url maybe_index_url unicode = do + let + visible_ifaces = filter visible ifaces + visible i = OptHide `notElem` ifaceOptions i + when (not (isJust maybe_contents_url)) $ + ppHtmlContents odir doctitle maybe_package + maybe_html_help_format 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 + + when (not (isJust maybe_index_url)) $ + ppHtmlIndex odir doctitle maybe_package maybe_html_help_format + maybe_contents_url maybe_source_url maybe_wiki_url + (map toInstalledIface visible_ifaces) + + when (not (isJust maybe_contents_url && isJust maybe_index_url)) $ + ppHtmlHelpFiles doctitle maybe_package ifaces odir maybe_html_help_format [] + + mapM_ (ppHtmlModule odir doctitle + maybe_source_url maybe_wiki_url + maybe_contents_url maybe_index_url unicode) visible_ifaces + +ppHtmlHelpFiles + :: String -- doctitle + -> Maybe String -- package + -> [Interface] + -> FilePath -- destination directory + -> Maybe String -- the Html Help format (--html-help) + -> [FilePath] -- external packages paths + -> IO () +ppHtmlHelpFiles doctitle maybe_package ifaces odir maybe_html_help_format pkg_paths = do + let + visible_ifaces = filter visible ifaces + visible i = OptHide `notElem` ifaceOptions i + + -- Generate index and contents page for Html Help if requested + case maybe_html_help_format of + Nothing -> return () + Just "mshelp" -> ppHHProject odir doctitle maybe_package visible_ifaces pkg_paths + Just "mshelp2" -> do + ppHH2Files odir maybe_package visible_ifaces pkg_paths + ppHH2Collection odir doctitle maybe_package + Just "devhelp" -> ppDevHelpFile odir doctitle maybe_package visible_ifaces + Just format -> fail ("The "++format++" format is not implemented") + +copyFile :: FilePath -> FilePath -> IO () +copyFile fromFPath toFPath = + (bracket (openFile fromFPath ReadMode) hClose $ \hFrom -> + bracket (openFile toFPath WriteMode) hClose $ \hTo -> + allocaBytes bufferSize $ \buffer -> + copyContents hFrom hTo buffer) + where + bufferSize = 1024 + + copyContents hFrom hTo buffer = do + count <- hGetBuf hFrom buffer bufferSize + when (count > 0) $ do + hPutBuf hTo buffer count + copyContents hFrom hTo buffer + + +copyHtmlBits :: FilePath -> FilePath -> Maybe FilePath -> IO () +copyHtmlBits odir libdir maybe_css = do + let + libhtmldir = pathJoin [libdir, "html"] + css_file = case maybe_css of + Nothing -> pathJoin [libhtmldir, 'x':cssFile] + Just f -> f + css_destination = pathJoin [odir, cssFile] + copyLibFile f = do + copyFile (pathJoin [libhtmldir, f]) (pathJoin [odir, f]) + copyFile css_file css_destination + mapM_ copyLibFile [ iconFile, plusFile, minusFile, jsFile, framesFile ] + +footer :: Html +footer = + thediv ! [theclass "bottom"] << paragraph << ( + "Produced by " +++ + (anchor ! [href projectUrl] << toHtml projectName) +++ + (" version " ++ projectVersion) + ) + +srcButton :: SourceURLs -> Maybe Interface -> Maybe Html +srcButton (Just src_base_url, _, _) Nothing = + Just (anchor ! [href src_base_url] << "Source code") +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 code") +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 = maybe contentsHtmlFile id maybe_contents_url + +indexButton :: Maybe String -> Maybe Html +indexButton maybe_index_url + = Just (anchor ! [href url] << "Index") + where url = maybe indexHtmlFile id maybe_index_url + +simpleHeader :: String -> Maybe String -> Maybe String + -> SourceURLs -> WikiURLs -> Html +simpleHeader doctitle maybe_contents_url maybe_index_url + maybe_source_url maybe_wiki_url = + thediv ! [theclass "package-header"] << ( + paragraph ! [theclass "caption"] << doctitle +++ + unordList (catMaybes [ + srcButton maybe_source_url Nothing, + wikiButton maybe_wiki_url Nothing, + contentsButton maybe_contents_url, + indexButton maybe_index_url + ]) ! [theclass "links"] + ) + +pageHeader :: String -> Interface -> String + -> SourceURLs -> WikiURLs + -> Maybe String -> Maybe String -> Html +pageHeader mdl iface doctitle + maybe_source_url maybe_wiki_url + maybe_contents_url maybe_index_url = + thediv ! [theclass "package-header"] << ( + paragraph ! [theclass "caption"] << (doctitle +++ spaceHtml) +++ + unordList (catMaybes [ + srcButton maybe_source_url (Just iface), + wikiButton maybe_wiki_url (Just $ ifaceMod iface), + contentsButton maybe_contents_url, + indexButton maybe_index_url + ]) ! [theclass "links"] + ) +++ + thediv ! [theclass "module-header"] << ( + paragraph ! [theclass "caption"] << mdl +++ + moduleInfo iface + ) + +moduleInfo :: Interface -> Html +moduleInfo iface = + let + info = ifaceInfo iface + + doOneEntry :: (String, (HaddockModInfo GHC.Name) -> Maybe String) -> Maybe (String, String) + doOneEntry (fieldName, field) = field info >>= \a -> return (fieldName, a) + + entries :: [(String, String)] + entries = mapMaybe doOneEntry [ + ("Portability",hmi_portability), + ("Stability",hmi_stability), + ("Maintainer",hmi_maintainer) + ] + in + case entries of + [] -> noHtml + _ -> defList entries ! [theclass "info"] + +-- --------------------------------------------------------------------------- +-- Generate the module contents + +ppHtmlContents + :: FilePath + -> String + -> Maybe String + -> Maybe String + -> Maybe String + -> SourceURLs + -> WikiURLs + -> [InstalledInterface] -> Bool -> Maybe (Doc GHC.RdrName) + -> IO () +ppHtmlContents odir doctitle + maybe_package maybe_html_help_format maybe_index_url + maybe_source_url maybe_wiki_url ifaces showPkgs prologue = do + let tree = mkModuleTree showPkgs + [(instMod iface, toInstalledDescription iface) | iface <- ifaces] + html = + header + (documentCharacterEncoding +++ + thetitle (toHtml doctitle) +++ + styleSheet +++ + (script ! [src jsFile, thetype "text/javascript"] $ noHtml)) +++ + body << ( + simpleHeader doctitle Nothing maybe_index_url + maybe_source_url maybe_wiki_url +++ + vanillaTable << ( + ppPrologue doctitle prologue </> + ppModuleTree doctitle tree) +++ + footer + ) + createDirectoryIfMissing True odir + writeFile (pathJoin [odir, contentsHtmlFile]) (renderToString html) + + -- XXX: think of a better place for this? + ppHtmlContentsFrame odir doctitle ifaces + + -- Generate contents page for Html Help if requested + case maybe_html_help_format of + Nothing -> return () + Just "mshelp" -> ppHHContents odir doctitle maybe_package tree + Just "mshelp2" -> ppHH2Contents odir doctitle maybe_package tree + Just "devhelp" -> return () + Just format -> fail ("The "++format++" format is not implemented") + +ppPrologue :: String -> Maybe (Doc GHC.RdrName) -> HtmlTable +ppPrologue _ Nothing = emptyTable +ppPrologue title (Just doc) = + (tda [theclass "section1"] << toHtml title) </> + docBox (rdrDocToHtml doc) + +ppModuleTree :: String -> [ModuleTree] -> HtmlTable +ppModuleTree _ ts = + tda [theclass "section1"] << toHtml "Modules" </> + td << vanillaTable2 << htmlTable + where + genTable tbl id_ [] = (tbl, id_) + genTable tbl id_ (x:xs) = genTable (tbl </> u) id' xs + where + (u,id') = mkNode [] x 0 id_ + + (htmlTable,_) = genTable emptyTable 0 ts + +mkNode :: [String] -> ModuleTree -> Int -> Int -> (HtmlTable,Int) +mkNode ss (Node s leaf pkg short ts) depth id_ = htmlNode + where + htmlNode = case ts of + [] -> (td_pad_w 1.25 depth << htmlModule <-> shortDescr <-> htmlPkg,id_) + _ -> (td_w depth << (collapsebutton id_s +++ htmlModule) <-> shortDescr <-> htmlPkg </> + (td_subtree << sub_tree), id') + + mod_width = 50::Int {-em-} + + td_pad_w :: Double -> Int -> Html -> HtmlTable + td_pad_w pad depth_ = + tda [thestyle ("padding-left: " ++ show pad ++ "em;" ++ + "width: " ++ show (mod_width - depth_*2) ++ "em")] + + td_w depth_ = + tda [thestyle ("width: " ++ show (mod_width - depth_*2) ++ "em")] + + td_subtree = + tda [thestyle ("padding: 0; padding-left: 2em")] + + shortDescr :: HtmlTable + shortDescr = case short of + Nothing -> cell $ td empty + Just doc -> tda [theclass "rdoc"] (origDocToHtml doc) + + htmlModule + | leaf = ppModule (mkModule (stringToPackageId pkgName) + (mkModuleName mdl)) "" + | otherwise = toHtml s + + -- ehm.. TODO: change the ModuleTree type + (htmlPkg, pkgName) = case pkg of + Nothing -> (td << empty, "") + Just p -> (td << toHtml p, p) + + mdl = foldr (++) "" (s' : map ('.':) ss') + (s':ss') = reverse (s:ss) + -- reconstruct the module name + + id_s = "n." ++ show id_ + + (sub_tree,id') = genSubTree emptyTable (id_+1) ts + + genSubTree :: HtmlTable -> Int -> [ModuleTree] -> (Html,Int) + genSubTree htmlTable id__ [] = (sub_tree_, id__) + where + sub_tree_ = collapsed vanillaTable2 id_s htmlTable + genSubTree htmlTable id__ (x:xs) = genSubTree (htmlTable </> u) id__' xs + where + (u,id__') = mkNode (s:ss) x (depth+1) id__ + + +-- | 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 -> [InstalledInterface] -> IO () +ppHtmlContentsFrame odir doctitle ifaces = do + let mods = flatModuleTree ifaces + html = + header + (documentCharacterEncoding +++ + thetitle (toHtml doctitle) +++ + styleSheet +++ + (script ! [src jsFile, thetype "text/javascript"] $ noHtml)) +++ + body << vanillaTable << Html.p << ( + foldr (+++) noHtml (map (+++br) mods)) + createDirectoryIfMissing True odir + writeFile (pathJoin [odir, frameIndexHtmlFile]) (renderToString html) + +-- --------------------------------------------------------------------------- +-- Generate the index + +ppHtmlIndex :: FilePath + -> String + -> Maybe String + -> Maybe String + -> Maybe String + -> SourceURLs + -> WikiURLs + -> [InstalledInterface] + -> IO () +ppHtmlIndex odir doctitle maybe_package maybe_html_help_format + maybe_contents_url maybe_source_url maybe_wiki_url ifaces = do + let html = + header (documentCharacterEncoding +++ + thetitle (toHtml (doctitle ++ " (Index)")) +++ + styleSheet +++ + (script ! [src jsFile, thetype "text/javascript"] $ noHtml)) +++ + body << ( + simpleHeader doctitle maybe_contents_url Nothing + maybe_source_url maybe_wiki_url +++ + vanillaTable << index_html + ) + + createDirectoryIfMissing True odir + + when split_indices $ + mapM_ (do_sub_index index) initialChars + + writeFile (pathJoin [odir, indexHtmlFile]) (renderToString html) + + -- Generate index and contents page for Html Help if requested + case maybe_html_help_format of + Nothing -> return () + Just "mshelp" -> ppHHIndex odir maybe_package ifaces + Just "mshelp2" -> ppHH2Index odir maybe_package ifaces + Just "devhelp" -> return () + Just format -> fail ("The "++format++" format is not implemented") + where + + index_html + | split_indices = + tda [theclass "section1"] << + toHtml ("Index") </> + indexInitialLetterLinks + | otherwise = + cell $ td << setTrClass (table ! [identifier "indexlist", cellpadding 0, cellspacing 5] << + aboves (map indexElt index)) + + -- 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 + + setTrClass :: Html -> Html + setTrClass = id + -- XHtml is more strict about not allowing you to poke inside a structure + -- hence this approach won't work for now -- since the whole table is + -- going away soon, this is just disabled for now. +{- + setTrClass (Html xs) = Html $ map f xs + where + f (HtmlTag name attrs inner) + | map toUpper name == "TR" = HtmlTag name (theclass "indexrow":attrs) inner + | otherwise = HtmlTag name attrs (setTrClass inner) + f x = x +-} + indexInitialLetterLinks = + td << setTrClass (table ! [cellpadding 0, cellspacing 5] << + besides [ td << anchor ! [href (subIndexHtmlFile c)] << + toHtml [c] + | c <- initialChars + , any ((==c) . toUpper . head . fst) index ]) + + -- 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 (pathJoin [odir, subIndexHtmlFile c]) (renderToString html) + where + html = header (documentCharacterEncoding +++ + thetitle (toHtml (doctitle ++ " (Index)")) +++ + styleSheet) +++ + body << ( + simpleHeader doctitle maybe_contents_url Nothing + maybe_source_url maybe_wiki_url +++ + vanillaTable << ( + indexInitialLetterLinks </> + tda [theclass "section1"] << + toHtml ("Index (" ++ c:")") </> + td << setTrClass (table ! [identifier "indexlist", cellpadding 0, cellspacing 5] << + aboves (map indexElt 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,_) = map toUpper n1 `compare` map toUpper 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 (++))) + (concat (map getIfaceIndex ifaces)) + + getIfaceIndex iface = + [ (getOccString name + , Map.fromList [(name, [(mdl, name `elem` instVisibleExports iface)])]) + | name <- instExports iface ] + where mdl = instMod iface + + indexElt :: (String, Map GHC.Name [(Module,Bool)]) -> HtmlTable + indexElt (str, entities) = + case Map.toAscList entities of + [(nm,entries)] -> + tda [ theclass "indexentry" ] << toHtml str <-> + indexLinks nm entries + many_entities -> + tda [ theclass "indexentry" ] << toHtml str </> + aboves (map doAnnotatedEntity (zip [1..] many_entities)) + + doAnnotatedEntity :: (Integer, (Name, [(Module, Bool)])) -> HtmlTable + doAnnotatedEntity (j,(nm,entries)) + = tda [ theclass "indexannot" ] << + 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 = + tda [ theclass "indexlinks" ] << + 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 + -> SourceURLs -> WikiURLs + -> Maybe String -> Maybe String -> Bool + -> Interface -> IO () +ppHtmlModule odir doctitle + maybe_source_url maybe_wiki_url + maybe_contents_url maybe_index_url unicode iface = do + let + mdl = ifaceMod iface + mdl_str = moduleString mdl + html = + header (documentCharacterEncoding +++ + thetitle (toHtml mdl_str) +++ + styleSheet +++ + (script ! [src jsFile, thetype "text/javascript"] $ noHtml) +++ + (script ! [thetype "text/javascript"] + -- XXX: quoting errors possible? + << ("window.onload = function () {setSynopsis(\"mini_" + ++ moduleHtmlFile mdl ++ "\")};")) + ) +++ + body << ( + pageHeader mdl_str iface doctitle + maybe_source_url maybe_wiki_url + maybe_contents_url maybe_index_url +++ + ifaceToHtml maybe_source_url maybe_wiki_url iface unicode +++ + footer) + + createDirectoryIfMissing True odir + writeFile (pathJoin [odir, moduleHtmlFile mdl]) (renderToString html) + ppHtmlModuleMiniSynopsis odir doctitle iface unicode + +ppHtmlModuleMiniSynopsis :: FilePath -> String -> Interface -> Bool -> IO () +ppHtmlModuleMiniSynopsis odir _doctitle iface unicode = do + let mdl = ifaceMod iface + html = + header + (documentCharacterEncoding +++ + thetitle (toHtml $ moduleString mdl) +++ + styleSheet +++ + (script ! [src jsFile, thetype "text/javascript"] $ noHtml)) +++ + body << thediv ! [ theclass "outer" ] << ( + (thediv ! [theclass "mini-topbar"] + << toHtml (moduleString mdl)) +++ + miniSynopsis mdl iface unicode) + createDirectoryIfMissing True odir + writeFile (pathJoin [odir, "mini_" ++ moduleHtmlFile mdl]) (renderToString html) + +ifaceToHtml :: SourceURLs -> WikiURLs -> Interface -> Bool -> Html +ifaceToHtml maybe_source_url maybe_wiki_url iface unicode + = ppModuleContents exports +++ + description +++ + synopsis +++ + 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 _ doc _ _) = isJust (fst doc) + has_doc (ExportNoDecl _ _) = False + has_doc (ExportModule _) = False + has_doc _ = True + + no_doc_at_all = not (any has_doc exports) + + description + = case ifaceRnDoc iface of + Nothing -> noHtml + Just doc -> h1 << toHtml "Description" +++ docToHtml doc + + -- omit the synopsis if there are no documentation annotations at all + synopsis + | no_doc_at_all = noHtml + | otherwise + = h1 << "Synopsis" +++ + unordList ( + rights $ + map (processExport True linksInfo unicode) exports + ) ! [theclass "synopsis"] + + -- 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 $ + map (either id (paragraph ! [theclass "decl"] <<)) $ + map (processExport False linksInfo unicode) exports + + linksInfo = (maybe_source_url, maybe_wiki_url) + +miniSynopsis :: Module -> Interface -> Bool -> Html +miniSynopsis mdl iface unicode = + thediv ! [ theclass "mini-synopsis" ] + << hsep (map (processForMiniSynopsis mdl unicode) $ exports) + where + exports = numberSectionHeadings (ifaceRnExportItems iface) + +processForMiniSynopsis :: Module -> Bool -> ExportItem DocName -> Html +processForMiniSynopsis mdl unicode (ExportDecl (L _loc decl0) _doc _ _insts) = + thediv ! [theclass "decl" ] << + case decl0 of + TyClD d@(TyFamily{}) -> ppTyFamHeader True False d unicode + TyClD d@(TyData{tcdTyPats = ps}) + | Nothing <- ps -> keyword "data" <++> ppTyClBinderWithVarsMini mdl d + | Just _ <- ps -> keyword "data" <++> keyword "instance" + <++> ppTyClBinderWithVarsMini mdl d + TyClD d@(TySynonym{tcdTyPats = ps}) + | Nothing <- ps -> keyword "type" <++> ppTyClBinderWithVarsMini mdl d + | Just _ <- ps -> keyword "type" <++> keyword "instance" + <++> ppTyClBinderWithVarsMini mdl d + TyClD d@(ClassDecl {}) -> + keyword "class" <++> ppTyClBinderWithVarsMini mdl d + SigD (TypeSig (L _ n) (L _ _)) -> + let nm = docNameOcc n + in ppNameMini mdl nm + _ -> noHtml +processForMiniSynopsis _ _ (ExportGroup lvl _id txt) = + let heading + | lvl == 1 = h1 + | lvl == 2 = h2 + | lvl >= 3 = h3 + | otherwise = error "bad group level" + in heading << docToHtml txt +processForMiniSynopsis _ _ _ = noHtml + +ppNameMini :: Module -> OccName -> Html +ppNameMini mdl nm = + anchor ! [ href ( moduleHtmlFile mdl ++ "#" + ++ (escapeStr (anchorNameStr nm))) + , target mainFrameName ] + << ppBinder' nm + +ppTyClBinderWithVarsMini :: Module -> TyClDecl DocName -> Html +ppTyClBinderWithVarsMini mdl decl = + let n = unLoc $ tcdLName decl + ns = tyvarNames $ tcdTyVars decl + in ppTypeApp n ns (ppNameMini mdl . docNameOcc) ppTyName + +ppModuleContents :: [ExportItem DocName] -> Html +ppModuleContents exports + | null sections = noHtml + | otherwise = contentsDiv + where + contentsDiv = thediv ! [theclass "table-of-contents"] << ( + paragraph ! [theclass "caption"] << "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 id0 << docToHtml 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 exports = go 1 exports + 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 -> (ExportItem DocName) + -> Either Html Html -- Right is a decl, Left is a "extra" (doc or group) +processExport _ _ _ (ExportGroup lev id0 doc) + = Left $ groupTag lev << namedAnchor id0 << docToHtml doc +processExport summary links unicode (ExportDecl decl doc subdocs insts) + = Right $ ppDecl' summary links decl doc insts subdocs unicode +processExport _ _ _ (ExportNoDecl y []) + = Right $ ppDocName y +processExport _ _ _ (ExportNoDecl y subs) + = Right $ ppDocName y +++ parenList (map ppDocName subs) +processExport _ _ _ (ExportDoc doc) + = Left $ docToHtml doc +processExport _ _ _ (ExportModule mdl) + = Right $ toHtml "module" +++ ppModule mdl "" + +groupTag :: Int -> Html -> Html +groupTag lev + | lev == 1 = h1 + | lev == 2 = h2 + | lev == 3 = h3 + | otherwise = h4 + + + + diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs new file mode 100644 index 00000000..db6d90a0 --- /dev/null +++ b/src/Haddock/Backends/Xhtml/Decl.hs @@ -0,0 +1,874 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Backends.Html.Decl +-- Copyright : (c) Simon Marlow 2003-2006, +-- David Waern 2006-2009, +-- Mark Lentczner 2010 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- + +module Haddock.Backends.Xhtml.Decl where + +import Haddock.Backends.Xhtml.DocMarkup +import Haddock.Backends.Xhtml.Layout +import Haddock.Backends.Xhtml.Names +import Haddock.Backends.Xhtml.Types +import Haddock.Backends.Xhtml.Util +import Haddock.GhcUtils +import Haddock.Types + +import Control.Monad ( join ) +import qualified Data.Map as Map +import Data.Maybe +import Text.XHtml hiding ( name, title, p, quote ) + +import BasicTypes ( IPName(..), Boxity(..) ) +import GHC +import Name +import Outputable ( ppr, showSDoc, Outputable ) + + +-- TODO: use DeclInfo DocName or something +ppDecl' :: Bool -> LinksInfo -> LHsDecl DocName -> + DocForDecl DocName -> [DocInstance DocName] -> [(DocName, DocForDecl DocName)] -> Bool -> Html +ppDecl' s k l m i d u = vanillaTable << ppDecl s k l m i d u + +ppDecl :: Bool -> LinksInfo -> LHsDecl DocName -> + DocForDecl DocName -> [DocInstance DocName] -> [(DocName, DocForDecl DocName)] -> Bool -> HtmlTable +ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances subdocs unicode = case decl of + TyClD d@(TyFamily {}) -> ppTyFam summ False links loc mbDoc d unicode + TyClD d@(TyData {}) + | Nothing <- tcdTyPats d -> ppDataDecl summ links instances subdocs loc mbDoc d unicode + | Just _ <- tcdTyPats d -> ppDataInst summ links loc mbDoc d + TyClD d@(TySynonym {}) + | Nothing <- tcdTyPats d -> ppTySyn summ links loc (mbDoc, fnArgsDoc) d unicode + | Just _ <- tcdTyPats d -> ppTyInst summ False links loc mbDoc d unicode + TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances loc mbDoc subdocs d unicode + SigD (TypeSig (L _ n) (L _ t)) -> ppFunSig summ links loc (mbDoc, fnArgsDoc) n t unicode + ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d unicode + InstD _ -> emptyTable + _ -> error "declaration not supported by ppDecl" + +ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> + DocName -> HsType DocName -> Bool -> HtmlTable +ppFunSig summary links loc doc docname typ unicode = + ppTypeOrFunSig summary links loc docname typ doc + (ppTypeSig summary occname typ unicode, ppBinder False occname, dcolon unicode) unicode + where + occname = docNameOcc docname + +ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> DocName -> HsType DocName -> + DocForDecl DocName -> (Html, Html, Html) -> Bool -> HtmlTable +ppTypeOrFunSig summary links loc docname typ (doc, argDocs) (pref1, pref2, sep) unicode + | summary || Map.null argDocs = declWithDoc summary links loc docname doc pref1 + | otherwise = topDeclBox links loc docname pref2 </> + (tda [theclass "body"] << vanillaTable << ( + do_args 0 sep typ </> + (case doc of + Just d -> ndocBox (docToHtml d) + Nothing -> emptyTable) + )) + where + argDocHtml n = case Map.lookup n argDocs of + Just adoc -> docToHtml adoc + Nothing -> noHtml + + do_largs n leader (L _ t) = do_args n leader t + do_args :: Int -> Html -> (HsType DocName) -> HtmlTable + do_args n leader (HsForAllTy Explicit tvs lctxt ltype) + = (argBox ( + leader <+> + hsep (forallSymbol unicode : ppTyVars tvs ++ [dot]) <+> + ppLContextNoArrow lctxt unicode) + <-> rdocBox noHtml) </> + do_largs n (darrow unicode) ltype + do_args n leader (HsForAllTy Implicit _ lctxt ltype) + | not (null (unLoc lctxt)) + = (argBox (leader <+> ppLContextNoArrow lctxt unicode) + <-> rdocBox noHtml) </> + do_largs n (darrow unicode) ltype + -- if we're not showing any 'forall' or class constraints or + -- anything, skip having an empty line for the context. + | otherwise + = do_largs n leader ltype + do_args n leader (HsFunTy lt r) + = (argBox (leader <+> ppLFunLhType unicode lt) <-> rdocBox (argDocHtml n)) + </> do_largs (n+1) (arrow unicode) r + do_args n leader t + = argBox (leader <+> ppType unicode t) <-> rdocBox (argDocHtml n) + + +ppTyVars :: [LHsTyVarBndr DocName] -> [Html] +ppTyVars tvs = map ppTyName (tyvarNames tvs) + + +tyvarNames :: [LHsTyVarBndr DocName] -> [Name] +tyvarNames = map (getName . hsTyVarName . unLoc) + + +ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> ForeignDecl DocName -> Bool -> HtmlTable +ppFor summary links loc doc (ForeignImport (L _ name) (L _ typ) _) unicode + = ppFunSig summary links loc doc name typ unicode +ppFor _ _ _ _ _ _ = error "ppFor" + + +-- we skip type patterns for now +ppTySyn :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> TyClDecl DocName -> Bool -> HtmlTable +ppTySyn summary links loc doc (TySynonym (L _ name) ltyvars _ ltype) unicode + = ppTypeOrFunSig summary links loc name (unLoc ltype) doc + (full, hdr, spaceHtml +++ equals) unicode + where + hdr = hsep ([keyword "type", ppBinder summary occ] ++ ppTyVars ltyvars) + full = hdr <+> equals <+> ppLType unicode ltype + occ = docNameOcc name +ppTySyn _ _ _ _ _ _ = error "declaration not supported by ppTySyn" + + +ppTypeSig :: Bool -> OccName -> HsType DocName -> Bool -> Html +ppTypeSig summary nm ty unicode = ppBinder summary nm <+> dcolon unicode <+> ppType unicode ty + + +ppTyName :: Name -> Html +ppTyName name + | isNameSym name = parens (ppName name) + | otherwise = ppName name + + +-------------------------------------------------------------------------------- +-- Type families +-------------------------------------------------------------------------------- + + +ppTyFamHeader :: Bool -> Bool -> TyClDecl DocName -> Bool -> Html +ppTyFamHeader summary associated decl unicode = + + (case tcdFlavour decl of + TypeFamily + | associated -> keyword "type" + | otherwise -> keyword "type family" + DataFamily + | associated -> keyword "data" + | otherwise -> keyword "data family" + ) <+> + + ppTyClBinderWithVars summary decl <+> + + case tcdKind decl of + Just kind -> dcolon unicode <+> ppKind kind + Nothing -> empty + + +ppTyFam :: Bool -> Bool -> LinksInfo -> SrcSpan -> Maybe (Doc DocName) -> + TyClDecl DocName -> Bool -> HtmlTable +ppTyFam summary associated links loc mbDoc decl unicode + + | summary = declWithDoc summary links loc docname mbDoc + (ppTyFamHeader True associated decl unicode) + + | associated, isJust mbDoc = header_ </> bodyBox << doc + | associated = header_ + | null instances, isJust mbDoc = header_ </> bodyBox << doc + | null instances = header_ + | isJust mbDoc = header_ </> bodyBox << (doc </> instancesBit) + | otherwise = header_ </> bodyBox << instancesBit + + where + docname = tcdName decl + + header_ = topDeclBox links loc docname (ppTyFamHeader summary associated decl unicode) + + doc = ndocBox . docToHtml . fromJust $ mbDoc + + instId = collapseId (getName docname) + + instancesBit = instHdr instId </> + tda [theclass "body"] << + collapsed thediv instId ( + spacedTable1 << ( + aboves (map (ppDocInstance unicode) instances) + ) + ) + + -- TODO: get the instances + instances = [] + + +-------------------------------------------------------------------------------- +-- Indexed data types +-------------------------------------------------------------------------------- + + +ppDataInst :: a +ppDataInst = undefined + + +-------------------------------------------------------------------------------- +-- Indexed newtypes +-------------------------------------------------------------------------------- + +-- TODO +-- ppNewTyInst = undefined + + +-------------------------------------------------------------------------------- +-- Indexed types +-------------------------------------------------------------------------------- + + +ppTyInst :: Bool -> Bool -> LinksInfo -> SrcSpan -> Maybe (Doc DocName) -> + TyClDecl DocName -> Bool -> HtmlTable +ppTyInst summary associated links loc mbDoc decl unicode + + | summary = declWithDoc summary links loc docname mbDoc + (ppTyInstHeader True associated decl unicode) + + | isJust mbDoc = header_ </> bodyBox << doc + | otherwise = header_ + + where + docname = tcdName decl + + header_ = topDeclBox links loc docname (ppTyInstHeader summary associated decl unicode) + + doc = case mbDoc of + Just d -> ndocBox (docToHtml d) + Nothing -> emptyTable + + +ppTyInstHeader :: Bool -> Bool -> TyClDecl DocName -> Bool -> Html +ppTyInstHeader _ _ decl unicode = + keyword "type instance" <+> + ppAppNameTypes (tcdName decl) typeArgs unicode + where + typeArgs = map unLoc . fromJust . tcdTyPats $ decl + + +-------------------------------------------------------------------------------- +-- Associated Types +-------------------------------------------------------------------------------- + + +ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LTyClDecl DocName -> Bool -> HtmlTable +ppAssocType summ links doc (L loc decl) unicode = + case decl of + TyFamily {} -> ppTyFam summ True links loc (fst doc) decl unicode + TySynonym {} -> ppTySyn summ links loc doc decl unicode + _ -> error "declaration type not supported by ppAssocType" + + +-------------------------------------------------------------------------------- +-- TyClDecl helpers +-------------------------------------------------------------------------------- + + +-- | Print a type family / newtype / data / class binder and its variables +ppTyClBinderWithVars :: Bool -> TyClDecl DocName -> Html +ppTyClBinderWithVars summ decl = + ppAppDocNameNames summ (unLoc $ tcdLName decl) (tyvarNames $ tcdTyVars decl) + + +-------------------------------------------------------------------------------- +-- Type applications +-------------------------------------------------------------------------------- + + +-- | Print an application of a DocName and a list of HsTypes +ppAppNameTypes :: DocName -> [HsType DocName] -> Bool -> Html +ppAppNameTypes n ts unicode = ppTypeApp n ts ppDocName (ppParendType unicode) + + +-- | Print an application of a DocName and a list of Names +ppAppDocNameNames :: Bool -> DocName -> [Name] -> Html +ppAppDocNameNames summ n ns = + ppTypeApp n ns (ppBinder summ . docNameOcc) ppTyName + + +-- | General printing of type applications +ppTypeApp :: DocName -> [a] -> (DocName -> Html) -> (a -> Html) -> Html +ppTypeApp n (t1:t2:rest) ppDN ppT + | operator, not . null $ rest = parens opApp <+> hsep (map ppT rest) + | operator = opApp + where + operator = isNameSym . getName $ n + opApp = ppT t1 <+> ppDN n <+> ppT t2 + +ppTypeApp n ts ppDN ppT = ppDN n <+> hsep (map ppT ts) + + +------------------------------------------------------------------------------- +-- Contexts +------------------------------------------------------------------------------- + + +ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Bool -> Html +ppLContext = ppContext . unLoc +ppLContextNoArrow = ppContextNoArrow . unLoc + + +ppContextNoArrow :: HsContext DocName -> Bool -> Html +ppContextNoArrow [] _ = empty +ppContextNoArrow cxt unicode = pp_hs_context (map unLoc cxt) unicode + + +ppContextNoLocs :: [HsPred DocName] -> Bool -> Html +ppContextNoLocs [] _ = empty +ppContextNoLocs cxt unicode = pp_hs_context cxt unicode <+> darrow unicode + + +ppContext :: HsContext DocName -> Bool -> Html +ppContext cxt unicode = ppContextNoLocs (map unLoc cxt) unicode + + +pp_hs_context :: [HsPred DocName] -> Bool -> Html +pp_hs_context [] _ = empty +pp_hs_context [p] unicode = ppPred unicode p +pp_hs_context cxt unicode = parenList (map (ppPred unicode) cxt) + + +ppPred :: Bool -> HsPred DocName -> Html +ppPred unicode (HsClassP n ts) = ppAppNameTypes n (map unLoc ts) unicode +ppPred unicode (HsEqualP t1 t2) = ppLType unicode t1 <+> toHtml "~" <+> ppLType unicode t2 +ppPred unicode (HsIParam (IPName n) t) + = toHtml "?" +++ ppDocName n <+> dcolon unicode <+> ppLType unicode t + + +------------------------------------------------------------------------------- +-- Class declarations +------------------------------------------------------------------------------- + + +ppClassHdr :: Bool -> Located [LHsPred DocName] -> DocName + -> [Located (HsTyVarBndr DocName)] -> [Located ([DocName], [DocName])] + -> Bool -> Html +ppClassHdr summ lctxt n tvs fds unicode = + keyword "class" + <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode else empty) + <+> ppAppDocNameNames summ n (tyvarNames $ tvs) + <+> ppFds fds unicode + + +ppFds :: [Located ([DocName], [DocName])] -> Bool -> Html +ppFds fds unicode = + if null fds then noHtml else + char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds)) + where + fundep (vars1,vars2) = hsep (map ppDocName vars1) <+> arrow unicode <+> + hsep (map ppDocName vars2) + +ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan -> [(DocName, DocForDecl DocName)] -> Bool -> HtmlTable +ppShortClassDecl summary links (ClassDecl lctxt lname tvs fds sigs _ ats _) loc subdocs unicode = + if null sigs && null ats + then (if summary then declBox else topDeclBox links loc nm) hdr + else (if summary then declBox else topDeclBox links loc nm) (hdr <+> keyword "where") + </> + ( + bodyBox << + aboves + ( + [ ppAssocType summary links doc at unicode | at <- ats + , let doc = lookupAnySubdoc (tcdName $ unL at) subdocs ] ++ + + [ ppFunSig summary links loc doc n typ unicode + | L _ (TypeSig (L _ n) (L _ typ)) <- sigs + , let doc = lookupAnySubdoc n subdocs ] + ) + ) + where + hdr = ppClassHdr summary lctxt (unLoc lname) tvs fds unicode + nm = unLoc lname +ppShortClassDecl _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" + + + +ppClassDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> SrcSpan + -> Maybe (Doc DocName) -> [(DocName, DocForDecl DocName)] + -> TyClDecl DocName -> Bool -> HtmlTable +ppClassDecl summary links instances loc mbDoc subdocs + decl@(ClassDecl lctxt lname ltyvars lfds lsigs _ ats _) unicode + | summary = ppShortClassDecl summary links decl loc subdocs unicode + | otherwise = classheader </> bodyBox << (classdoc </> body_ </> instancesBit) + where + classheader + | null lsigs = topDeclBox links loc nm (hdr unicode) + | otherwise = topDeclBox links loc nm (hdr unicode <+> keyword "where") + + nm = unLoc $ tcdLName decl + + hdr = ppClassHdr summary lctxt (unLoc lname) ltyvars lfds + + classdoc = case mbDoc of + Nothing -> emptyTable + Just d -> ndocBox (docToHtml d) + + body_ + | null lsigs, null ats = emptyTable + | null ats = s8 </> methHdr </> bodyBox << methodTable + | otherwise = s8 </> atHdr </> bodyBox << atTable </> + s8 </> methHdr </> bodyBox << methodTable + + methodTable = + abovesSep s8 [ ppFunSig summary links loc doc n typ unicode + | L _ (TypeSig (L _ n) (L _ typ)) <- lsigs + , let doc = lookupAnySubdoc n subdocs ] + + atTable = abovesSep s8 $ [ ppAssocType summary links doc at unicode | at <- ats + , let doc = lookupAnySubdoc (tcdName $ unL at) subdocs ] + + instId = collapseId (getName nm) + instancesBit + | null instances = emptyTable + | otherwise + = s8 </> instHdr instId </> + tda [theclass "body"] << + collapsed thediv instId ( + spacedTable1 << aboves (map (ppDocInstance unicode) instances) + ) +ppClassDecl _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" + + +-- | Print a possibly commented instance. The instance header is printed inside +-- an 'argBox'. The comment is printed to the right of the box in normal comment +-- style. +ppDocInstance :: Bool -> DocInstance DocName -> HtmlTable +ppDocInstance unicode (instHead, maybeDoc) = + argBox (ppInstHead unicode instHead) <-> maybeRDocBox maybeDoc + + +ppInstHead :: Bool -> InstHead DocName -> Html +ppInstHead unicode ([], n, ts) = ppAppNameTypes n ts unicode +ppInstHead unicode (ctxt, n, ts) = ppContextNoLocs ctxt unicode <+> ppAppNameTypes n ts unicode + + +lookupAnySubdoc :: (Eq name1) => + name1 -> [(name1, DocForDecl name2)] -> DocForDecl name2 +lookupAnySubdoc n subdocs = case lookup n subdocs of + Nothing -> noDocForDecl + Just docs -> docs + + + +-- ----------------------------------------------------------------------------- +-- Data & newtype declarations + + +-- TODO: print contexts +ppShortDataDecl :: Bool -> LinksInfo -> SrcSpan -> TyClDecl DocName -> Bool -> Html +ppShortDataDecl summary links loc dataDecl unicode + + | [lcon] <- cons, ResTyH98 <- resTy = + ppDataHeader summary dataDecl unicode + <+> equals <+> ppShortConstr summary (unLoc lcon) unicode + + | [] <- cons = ppDataHeader summary dataDecl unicode + + | otherwise = vanillaTable << ( + case resTy of + ResTyH98 -> dataHeader </> + tda [theclass "body"] << vanillaTable << ( + aboves (zipWith doConstr ('=':repeat '|') cons) + ) + ResTyGADT _ -> dataHeader </> + tda [theclass "body"] << vanillaTable << ( + aboves (map doGADTConstr cons) + ) + ) + + where + dataHeader = + (if summary then declBox else topDeclBox links loc docname) + ((ppDataHeader summary dataDecl unicode) <+> + case resTy of ResTyGADT _ -> keyword "where"; _ -> empty) + + doConstr c con = declBox (toHtml [c] <+> ppShortConstr summary (unLoc con) unicode) + doGADTConstr con = declBox (ppShortConstr summary (unLoc con) unicode) + + docname = unLoc . tcdLName $ dataDecl + cons = tcdCons dataDecl + resTy = (con_res . unLoc . head) cons + +ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> + [(DocName, DocForDecl DocName)] -> + SrcSpan -> Maybe (Doc DocName) -> TyClDecl DocName -> Bool -> HtmlTable +ppDataDecl summary links instances subdocs loc mbDoc dataDecl unicode + + | summary = declWithDoc summary links loc docname mbDoc + (ppShortDataDecl summary links loc dataDecl unicode) + + | otherwise + = (if validTable then (</>) else const) header_ $ + tda [theclass "body"] << vanillaTable << ( + datadoc </> + constrBit </> + instancesBit + ) + + + where + docname = unLoc . tcdLName $ dataDecl + cons = tcdCons dataDecl + resTy = (con_res . unLoc . head) cons + + header_ = topDeclBox links loc docname (ppDataHeader summary dataDecl unicode + <+> whereBit) + + whereBit + | null cons = empty + | otherwise = case resTy of + ResTyGADT _ -> keyword "where" + _ -> empty + + constrTable + | any isRecCon cons = spacedTable5 + | otherwise = spacedTable1 + + datadoc = case mbDoc of + Just doc -> ndocBox (docToHtml doc) + Nothing -> emptyTable + + constrBit + | null cons = emptyTable + | otherwise = constrHdr </> ( + tda [theclass "body"] << constrTable << + aboves (map (ppSideBySideConstr subdocs unicode) cons) + ) + + instId = collapseId (getName docname) + + instancesBit + | null instances = emptyTable + | otherwise + = instHdr instId </> + tda [theclass "body"] << + collapsed thediv instId ( + spacedTable1 << aboves (map (ppDocInstance unicode) instances + ) + ) + + validTable = isJust mbDoc || not (null cons) || not (null instances) + + +isRecCon :: Located (ConDecl a) -> Bool +isRecCon lcon = case con_details (unLoc lcon) of + RecCon _ -> True + _ -> False + + +ppShortConstr :: Bool -> ConDecl DocName -> Bool -> Html +ppShortConstr summary con unicode = case con_res con of + ResTyH98 -> case con_details con of + PrefixCon args -> header_ unicode +++ hsep (ppBinder summary occ : map (ppLParendType unicode) args) + RecCon fields -> header_ unicode +++ ppBinder summary occ <+> + doRecordFields fields + InfixCon arg1 arg2 -> header_ unicode +++ + hsep [ppLParendType unicode arg1, ppBinder summary occ, ppLParendType unicode arg2] + + ResTyGADT resTy -> case con_details con of + -- prefix & infix could use hsConDeclArgTys if it seemed to + -- simplify the code. + PrefixCon args -> doGADTCon args resTy + -- display GADT records with the new syntax, + -- Constr :: (Context) => { field :: a, field2 :: b } -> Ty (a, b) + -- (except each field gets its own line in docs, to match + -- non-GADT records) + RecCon fields -> ppBinder summary occ <+> dcolon unicode <+> hsep [ + ppForAll forall ltvs lcontext unicode, + doRecordFields fields, + arrow unicode <+> ppLType unicode resTy ] + InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy + + where + doRecordFields fields = braces (vanillaTable << + aboves (map (ppShortField summary unicode) fields)) + doGADTCon args resTy = ppBinder summary occ <+> dcolon unicode <+> hsep [ + ppForAll forall ltvs lcontext unicode, + ppLType unicode (foldr mkFunTy resTy args) ] + + header_ = ppConstrHdr forall tyVars context + occ = docNameOcc . unLoc . con_name $ con + ltvs = con_qvars con + tyVars = tyvarNames ltvs + lcontext = con_cxt con + context = unLoc (con_cxt con) + forall = con_explicit con + mkFunTy a b = noLoc (HsFunTy a b) + +-- ppConstrHdr is for (non-GADT) existentials constructors' syntax +ppConstrHdr :: HsExplicitForAll -> [Name] -> HsContext DocName -> Bool -> Html +ppConstrHdr forall tvs ctxt unicode + = (if null tvs then noHtml else ppForall) + +++ + (if null ctxt then noHtml else ppContextNoArrow ctxt unicode <+> darrow unicode +++ toHtml " ") + where + ppForall = case forall of + Explicit -> forallSymbol unicode <+> hsep (map ppName tvs) <+> toHtml ". " + Implicit -> empty + +ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LConDecl DocName -> HtmlTable +ppSideBySideConstr subdocs unicode (L _ con) = case con_res con of + + ResTyH98 -> case con_details con of + + PrefixCon args -> + argBox (hsep ((header_ unicode +++ ppBinder False occ) : map (ppLParendType unicode) args)) + <-> maybeRDocBox mbDoc + + RecCon fields -> + argBox (header_ unicode +++ ppBinder False occ) <-> + maybeRDocBox mbDoc + </> + doRecordFields fields + + InfixCon arg1 arg2 -> + argBox (hsep [header_ unicode+++ppLParendType unicode arg1, ppBinder False occ, ppLParendType unicode arg2]) + <-> maybeRDocBox mbDoc + + ResTyGADT resTy -> case con_details con of + -- prefix & infix could also use hsConDeclArgTys if it seemed to + -- simplify the code. + PrefixCon args -> doGADTCon args resTy + cd@(RecCon fields) -> doGADTCon (hsConDeclArgTys cd) resTy + </> doRecordFields fields + InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy + + where + doRecordFields fields = + (tda [theclass "body"] << spacedTable1 << + aboves (map (ppSideBySideField subdocs unicode) fields)) + doGADTCon args resTy = argBox (ppBinder False occ <+> dcolon unicode <+> hsep [ + ppForAll forall ltvs (con_cxt con) unicode, + ppLType unicode (foldr mkFunTy resTy args) ] + ) <-> maybeRDocBox mbDoc + + + header_ = ppConstrHdr forall tyVars context + occ = docNameOcc . unLoc . con_name $ con + ltvs = con_qvars con + tyVars = tyvarNames (con_qvars con) + context = unLoc (con_cxt con) + forall = con_explicit con + -- don't use "con_doc con", in case it's reconstructed from a .hi file, + -- or also because we want Haddock to do the doc-parsing, not GHC. + -- 'join' is in Maybe. + mbDoc = join $ fmap fst $ lookup (unLoc $ con_name con) subdocs + mkFunTy a b = noLoc (HsFunTy a b) + +ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocName -> HtmlTable +ppSideBySideField subdocs unicode (ConDeclField (L _ name) ltype _) = + argBox (ppBinder False (docNameOcc name) + <+> dcolon unicode <+> ppLType unicode ltype) <-> maybeRDocBox mbDoc + where + -- don't use cd_fld_doc for same reason we don't use con_doc above + mbDoc = join $ fmap fst $ lookup name subdocs + +{- +ppHsFullConstr :: HsConDecl -> Html +ppHsFullConstr (HsConDecl _ nm tvs ctxt typeList doc) = + declWithDoc False doc ( + hsep ((ppHsConstrHdr tvs ctxt +++ + ppHsBinder False nm) : map ppHsBangType typeList) + ) +ppHsFullConstr (HsRecDecl _ nm tvs ctxt fields doc) = + td << vanillaTable << ( + case doc of + Nothing -> aboves [hdr, fields_html] + Just _ -> aboves [hdr, constr_doc, fields_html] + ) + + where hdr = declBox (ppHsConstrHdr tvs ctxt +++ ppHsBinder False nm) + + constr_doc + | isJust doc = docBox (docToHtml (fromJust doc)) + | otherwise = emptyTable + + fields_html = + td << + table ! [width "100%", cellpadding 0, cellspacing 8] << ( + aboves (map ppFullField (concat (map expandField fields))) + ) +-} + +ppShortField :: Bool -> Bool -> ConDeclField DocName -> HtmlTable +ppShortField summary unicode (ConDeclField (L _ name) ltype _) + = tda [theclass "recfield"] << ( + ppBinder summary (docNameOcc name) + <+> dcolon unicode <+> ppLType unicode ltype + ) + +{- +ppFullField :: HsFieldDecl -> Html +ppFullField (HsFieldDecl [n] ty doc) + = declWithDoc False doc ( + ppHsBinder False n <+> dcolon <+> ppHsBangType ty + ) +ppFullField _ = error "ppFullField" + +expandField :: HsFieldDecl -> [HsFieldDecl] +expandField (HsFieldDecl ns ty doc) = [ HsFieldDecl [n] ty doc | n <- ns ] +-} + +-- | Print the LHS of a data\/newtype declaration. +-- Currently doesn't handle 'data instance' decls or kind signatures +ppDataHeader :: Bool -> TyClDecl DocName -> Bool -> Html +ppDataHeader summary decl unicode + | not (isDataDecl decl) = error "ppDataHeader: illegal argument" + | otherwise = + -- newtype or data + (if tcdND decl == NewType then keyword "newtype" else keyword "data") <+> + -- context + ppLContext (tcdCtxt decl) unicode <+> + -- T a b c ..., or a :+: b + ppTyClBinderWithVars summary decl + + +-- ---------------------------------------------------------------------------- +-- Types and contexts + + +ppKind :: Outputable a => a -> Html +ppKind k = toHtml $ showSDoc (ppr k) + + +{- +ppForAll Implicit _ lctxt = ppCtxtPart lctxt +ppForAll Explicit ltvs lctxt = + hsep (keyword "forall" : ppTyVars ltvs ++ [dot]) <+> ppCtxtPart lctxt +-} + + +ppBang :: HsBang -> Html +ppBang HsNoBang = empty +ppBang HsStrict = toHtml "!" +ppBang HsUnbox = toHtml "!" -- unboxed args is an implementation detail, + -- so we just show the strictness annotation + + +tupleParens :: Boxity -> [Html] -> Html +tupleParens Boxed = parenList +tupleParens Unboxed = ubxParenList +{- +ppType :: HsType DocName -> Html +ppType t = case t of + t@(HsForAllTy expl ltvs lcontext ltype) -> ppForAllTy t <+> ppLType ltype + HsTyVar n -> ppDocName n + HsBangTy HsStrict lt -> toHtml "!" <+> ppLType lt + HsBangTy HsUnbox lt -> toHtml "!!" <+> ppLType lt + HsAppTy a b -> ppLType a <+> ppLType b + HsFunTy a b -> hsep [ppLType a, toHtml "->", ppLType b] + HsListTy t -> brackets $ ppLType t + HsPArrTy t -> toHtml "[:" +++ ppLType t +++ toHtml ":]" + HsTupleTy Boxed ts -> parenList $ map ppLType ts + HsTupleTy Unboxed ts -> ubxParenList $ map ppLType ts + HsOpTy a n b -> ppLType a <+> ppLDocName n <+> ppLType b + HsParTy t -> parens $ ppLType t + HsNumTy n -> toHtml (show n) + HsPredTy p -> ppPred p + HsKindSig t k -> hsep [ppLType t, dcolon, ppKind k] + HsSpliceTy _ -> error "ppType" + HsDocTy t _ -> ppLType t +-} + + +-------------------------------------------------------------------------------- +-- Rendering of HsType +-------------------------------------------------------------------------------- + + +pREC_TOP, pREC_FUN, pREC_OP, pREC_CON :: Int + +pREC_TOP = (0 :: Int) -- type in ParseIface.y in GHC +pREC_FUN = (1 :: Int) -- btype in ParseIface.y in GHC + -- Used for LH arg of (->) +pREC_OP = (2 :: Int) -- Used for arg of any infix operator + -- (we don't keep their fixities around) +pREC_CON = (3 :: Int) -- Used for arg of type applicn: + -- always parenthesise unless atomic + +maybeParen :: Int -- Precedence of context + -> Int -- Precedence of top-level operator + -> Html -> Html -- Wrap in parens if (ctxt >= op) +maybeParen ctxt_prec op_prec p | ctxt_prec >= op_prec = parens p + | otherwise = p + + +ppLType, ppLParendType, ppLFunLhType :: Bool -> Located (HsType DocName) -> Html +ppLType unicode y = ppType unicode (unLoc y) +ppLParendType unicode y = ppParendType unicode (unLoc y) +ppLFunLhType unicode y = ppFunLhType unicode (unLoc y) + + +ppType, ppParendType, ppFunLhType :: Bool -> HsType DocName -> Html +ppType unicode ty = ppr_mono_ty pREC_TOP ty unicode +ppParendType unicode ty = ppr_mono_ty pREC_CON ty unicode +ppFunLhType unicode ty = ppr_mono_ty pREC_FUN ty unicode + + +-- Drop top-level for-all type variables in user style +-- since they are implicit in Haskell + +ppForAll :: HsExplicitForAll -> [Located (HsTyVarBndr DocName)] + -> Located (HsContext DocName) -> Bool -> Html +ppForAll expl tvs cxt unicode + | show_forall = forall_part <+> ppLContext cxt unicode + | otherwise = ppLContext cxt unicode + where + show_forall = not (null tvs) && is_explicit + is_explicit = case expl of {Explicit -> True; Implicit -> False} + forall_part = hsep (forallSymbol unicode : ppTyVars tvs) +++ dot + + +ppr_mono_lty :: Int -> LHsType DocName -> Bool -> Html +ppr_mono_lty ctxt_prec ty unicode = ppr_mono_ty ctxt_prec (unLoc ty) unicode + + +ppr_mono_ty :: Int -> HsType DocName -> Bool -> Html +ppr_mono_ty ctxt_prec (HsForAllTy expl tvs ctxt ty) unicode + = maybeParen ctxt_prec pREC_FUN $ + hsep [ppForAll expl tvs ctxt unicode, ppr_mono_lty pREC_TOP ty unicode] + +-- gaw 2004 +ppr_mono_ty _ (HsBangTy b ty) u = ppBang b +++ ppLParendType u ty +ppr_mono_ty _ (HsTyVar name) _ = ppDocName name +ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u = ppr_fun_ty ctxt_prec ty1 ty2 u +ppr_mono_ty _ (HsTupleTy con tys) u = tupleParens con (map (ppLType u) tys) +ppr_mono_ty _ (HsKindSig ty kind) u = parens (ppr_mono_lty pREC_TOP ty u <+> dcolon u <+> ppKind kind) +ppr_mono_ty _ (HsListTy ty) u = brackets (ppr_mono_lty pREC_TOP ty u) +ppr_mono_ty _ (HsPArrTy ty) u = pabrackets (ppr_mono_lty pREC_TOP ty u) +ppr_mono_ty _ (HsPredTy p) u = parens (ppPred u p) +ppr_mono_ty _ (HsNumTy n) _ = toHtml (show n) -- generics only +ppr_mono_ty _ (HsSpliceTy _) _ = error "ppr_mono_ty HsSpliceTy" +ppr_mono_ty _ (HsSpliceTyOut _) _ = error "ppr_mono_ty HsSpliceTyOut" +ppr_mono_ty _ (HsRecTy _) _ = error "ppr_mono_ty HsRecTy" + + +ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode + = maybeParen ctxt_prec pREC_CON $ + hsep [ppr_mono_lty pREC_FUN fun_ty unicode, ppr_mono_lty pREC_CON arg_ty unicode] + +ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode + = maybeParen ctxt_prec pREC_FUN $ + ppr_mono_lty pREC_OP ty1 unicode <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode + where + ppr_op = if not (isSymOcc occName) then quote (ppLDocName op) else ppLDocName op + occName = docNameOcc . unLoc $ op + +ppr_mono_ty ctxt_prec (HsParTy ty) unicode +-- = parens (ppr_mono_lty pREC_TOP ty) + = ppr_mono_lty ctxt_prec ty unicode + +ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode + = ppr_mono_lty ctxt_prec ty unicode + + +ppr_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Bool -> Html +ppr_fun_ty ctxt_prec ty1 ty2 unicode + = let p1 = ppr_mono_lty pREC_FUN ty1 unicode + p2 = ppr_mono_lty pREC_TOP ty2 unicode + in + maybeParen ctxt_prec pREC_FUN $ + hsep [p1, arrow unicode <+> p2] + + diff --git a/src/Haddock/Backends/Xhtml/DocMarkup.hs b/src/Haddock/Backends/Xhtml/DocMarkup.hs new file mode 100644 index 00000000..72314aec --- /dev/null +++ b/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -0,0 +1,99 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Backends.Html.DocMarkup +-- Copyright : (c) Simon Marlow 2003-2006, +-- David Waern 2006-2009, +-- Mark Lentczner 2010 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- + +module Haddock.Backends.Xhtml.DocMarkup where + +import Haddock.Backends.Xhtml.Names +import Haddock.Backends.Xhtml.Util +import Haddock.GhcUtils +import Haddock.Types +import Haddock.Utils + +import Text.XHtml hiding ( name, title, p, quote ) + +import GHC +import Name +import RdrName + + +parHtmlMarkup :: (a -> Html) -> (a -> Bool) -> DocMarkup a Html +parHtmlMarkup ppId isTyCon = Markup { + markupParagraph = paragraph, + markupEmpty = toHtml "", + markupString = toHtml, + markupAppend = (+++), + markupIdentifier = tt . ppId . choose, + markupModule = \m -> let (mdl,ref) = break (=='#') m in ppModule (mkModuleNoPackage mdl) ref, + markupEmphasis = emphasize . toHtml, + markupMonospaced = tt . toHtml, + markupUnorderedList = ulist . concatHtml . map (li <<), + markupPic = \path -> image ! [src path], + markupOrderedList = olist . concatHtml . map (li <<), + markupDefList = dlist . concatHtml . map markupDef, + markupCodeBlock = pre, + markupURL = \url -> anchor ! [href url] << toHtml url, + markupAName = \aname -> namedAnchor aname << toHtml "" + } + where + -- If an id can refer to multiple things, we give precedence to type + -- constructors. This should ideally be done during renaming from RdrName + -- to Name, but since we will move this process from GHC into Haddock in + -- the future, we fix it here in the meantime. + -- TODO: mention this rule in the documentation. + choose [] = error "empty identifier list in HsDoc" + choose [x] = x + choose (x:y:_) + | isTyCon x = x + | otherwise = y + + +markupDef :: (HTML a, HTML b) => (a, b) -> Html +markupDef (a,b) = dterm << a +++ ddef << b + + +htmlMarkup :: DocMarkup DocName Html +htmlMarkup = parHtmlMarkup ppDocName (isTyConName . getName) + +htmlOrigMarkup :: DocMarkup Name Html +htmlOrigMarkup = parHtmlMarkup ppName isTyConName + +htmlRdrMarkup :: DocMarkup RdrName Html +htmlRdrMarkup = parHtmlMarkup ppRdrName isRdrTc + +-- If the doc is a single paragraph, don't surround it with <P> (this causes +-- ugly extra whitespace with some browsers). +docToHtml :: Doc DocName -> Html +docToHtml doc = markup htmlMarkup (markup htmlCleanup doc) + +origDocToHtml :: Doc Name -> Html +origDocToHtml doc = markup htmlOrigMarkup (markup htmlCleanup doc) + +rdrDocToHtml :: Doc RdrName -> Html +rdrDocToHtml doc = markup htmlRdrMarkup (markup htmlCleanup doc) + +-- If there is a single paragraph, then surrounding it with <P>..</P> +-- can add too much whitespace in some browsers (eg. IE). However if +-- we have multiple paragraphs, then we want the extra whitespace to +-- separate them. So we catch the single paragraph case and transform it +-- here. +unParagraph :: Doc a -> Doc a +unParagraph (DocParagraph d) = d +--NO: This eliminates line breaks in the code block: (SDM, 6/5/2003) +--unParagraph (DocCodeBlock d) = (DocMonospaced d) +unParagraph doc = doc + +htmlCleanup :: DocMarkup a (Doc a) +htmlCleanup = idMarkup { + markupUnorderedList = DocUnorderedList . map unParagraph, + markupOrderedList = DocOrderedList . map unParagraph + } diff --git a/src/Haddock/Backends/Xhtml/Layout.hs b/src/Haddock/Backends/Xhtml/Layout.hs new file mode 100644 index 00000000..fa96049d --- /dev/null +++ b/src/Haddock/Backends/Xhtml/Layout.hs @@ -0,0 +1,127 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Backends.Html.Layout +-- Copyright : (c) Simon Marlow 2003-2006, +-- David Waern 2006-2009, +-- Mark Lentczner 2010 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- + +module Haddock.Backends.Xhtml.Layout where + +import Haddock.Backends.Xhtml.DocMarkup +import Haddock.Backends.Xhtml.Types +import Haddock.Backends.Xhtml.Util +import Haddock.Types + +import Text.XHtml hiding ( name, title, p, quote ) + +import FastString ( unpackFS ) +import GHC + + +declWithDoc :: Bool -> LinksInfo -> SrcSpan -> DocName -> Maybe (Doc DocName) -> Html -> HtmlTable +declWithDoc True _ _ _ _ html_decl = declBox html_decl +declWithDoc False links loc nm Nothing html_decl = topDeclBox links loc nm html_decl +declWithDoc False links loc nm (Just doc) html_decl = + topDeclBox links loc nm html_decl </> docBox (docToHtml doc) + + + +{- +text :: Html +text = strAttr "TEXT" +-} + +-- a box for displaying code +declBox :: Html -> HtmlTable +declBox html = tda [theclass "decl"] << html + +-- a box for top level documented names +-- it adds a source and wiki link at the right hand side of the box +topDeclBox :: LinksInfo -> SrcSpan -> DocName -> Html -> HtmlTable +topDeclBox ((_,_,Nothing), (_,_,Nothing)) _ _ html = declBox html +topDeclBox ((_,_,maybe_source_url), (_,_,maybe_wiki_url)) + loc name html = + tda [theclass "topdecl"] << + ( table ! [theclass "declbar"] << + ((tda [theclass "declname"] << html) + <-> srcLink + <-> wikiLink) + ) + where srcLink = + case maybe_source_url of + Nothing -> emptyTable + Just url -> tda [theclass "declbut"] << + let url' = spliceURL (Just fname) (Just origMod) + (Just n) (Just loc) url + in anchor ! [href url'] << toHtml "Source" + + wikiLink = + case maybe_wiki_url of + Nothing -> emptyTable + Just url -> tda [theclass "declbut"] << + let url' = spliceURL (Just fname) (Just mdl) + (Just n) (Just loc) url + in anchor ! [href url'] << toHtml "Comments" + + -- For source links, we want to point to the original module, + -- because only that will have the source. + -- TODO: do something about type instances. They will point to + -- the module defining the type family, which is wrong. + origMod = nameModule n + + -- Name must be documented, otherwise we wouldn't get here + Documented n mdl = name + + fname = unpackFS (srcSpanFile loc) + + +-- a box for displaying an 'argument' (some code which has text to the +-- right of it). Wrapping is not allowed in these boxes, whereas it is +-- in a declBox. +argBox :: Html -> HtmlTable +argBox html = tda [theclass "arg"] << html + +-- a box for displaying documentation, +-- indented and with a little padding at the top +docBox :: Html -> HtmlTable +docBox html = tda [theclass "doc"] << html + +-- a box for displaying documentation, not indented. +ndocBox :: Html -> HtmlTable +ndocBox html = tda [theclass "ndoc"] << html + +-- a box for displaying documentation, padded on the left a little +rdocBox :: Html -> HtmlTable +rdocBox html = tda [theclass "rdoc"] << html + +maybeRDocBox :: Maybe (Doc DocName) -> HtmlTable +maybeRDocBox Nothing = rdocBox (noHtml) +maybeRDocBox (Just doc) = rdocBox (docToHtml doc) + + +bodyBox :: Html -> HtmlTable +bodyBox html = tda [theclass "body"] << vanillaTable << html + +-- a vanilla table has width 100%, no border, no padding, no spacing +vanillaTable, vanillaTable2 :: Html -> Html +vanillaTable = table ! [theclass "vanilla", cellspacing 0, cellpadding 0] +vanillaTable2 = table ! [theclass "vanilla2", cellspacing 0, cellpadding 0] + +spacedTable1, spacedTable5 :: Html -> Html +spacedTable1 = table ! [theclass "vanilla", cellspacing 1, cellpadding 0] +spacedTable5 = table ! [theclass "vanilla", cellspacing 5, cellpadding 0] + +constrHdr, methHdr, atHdr :: HtmlTable +constrHdr = tda [ theclass "section4" ] << toHtml "Constructors" +methHdr = tda [ theclass "section4" ] << toHtml "Methods" +atHdr = tda [ theclass "section4" ] << toHtml "Associated Types" + +instHdr :: String -> HtmlTable +instHdr id_ = + tda [ theclass "section4" ] << (collapsebutton id_ +++ toHtml " Instances") diff --git a/src/Haddock/Backends/Xhtml/Names.hs b/src/Haddock/Backends/Xhtml/Names.hs new file mode 100644 index 00000000..cbf87c23 --- /dev/null +++ b/src/Haddock/Backends/Xhtml/Names.hs @@ -0,0 +1,76 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Backends.Html.Names +-- Copyright : (c) Simon Marlow 2003-2006, +-- David Waern 2006-2009, +-- Mark Lentczner 2010 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- + +module Haddock.Backends.Xhtml.Names where + +import Haddock.Backends.Xhtml.Util +import Haddock.GhcUtils +import Haddock.Types +import Haddock.Utils + +import Text.XHtml hiding ( name, title, p, quote ) + +import GHC +import Name +import RdrName + +ppOccName :: OccName -> Html +ppOccName = toHtml . occNameString + +ppRdrName :: RdrName -> Html +ppRdrName = ppOccName . rdrNameOcc + +ppLDocName :: Located DocName -> Html +ppLDocName (L _ d) = ppDocName d + +ppDocName :: DocName -> Html +ppDocName (Documented name mdl) = + linkIdOcc mdl (Just occName) << ppOccName occName + where occName = nameOccName name +ppDocName (Undocumented name) = toHtml (getOccString name) + +linkTarget :: OccName -> Html +linkTarget n = namedAnchor (anchorNameStr n) << toHtml "" + +ppName :: Name -> Html +ppName name = toHtml (getOccString name) + + +ppBinder :: Bool -> OccName -> Html +-- The Bool indicates whether we are generating the summary, in which case +-- the binder will be a link to the full definition. +ppBinder True n = linkedAnchor (anchorNameStr n) << ppBinder' n +ppBinder False n = linkTarget n +++ bold << ppBinder' n + + +ppBinder' :: OccName -> Html +ppBinder' n + | isVarSym n = parens $ ppOccName n + | otherwise = ppOccName n + + +linkId :: Module -> Maybe Name -> Html -> Html +linkId mdl mbName = linkIdOcc mdl (fmap nameOccName mbName) + + +linkIdOcc :: Module -> Maybe OccName -> Html -> Html +linkIdOcc mdl mbName = anchor ! [href uri] + where + uri = case mbName of + Nothing -> moduleHtmlFile mdl + Just name -> nameHtmlRef mdl name + +ppModule :: Module -> String -> Html +ppModule mdl ref = anchor ! [href ((moduleHtmlFile mdl) ++ ref)] + << toHtml (moduleString mdl) + diff --git a/src/Haddock/Backends/Xhtml/Types.hs b/src/Haddock/Backends/Xhtml/Types.hs new file mode 100644 index 00000000..e4d26fc9 --- /dev/null +++ b/src/Haddock/Backends/Xhtml/Types.hs @@ -0,0 +1,22 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Backends.Html.Types +-- Copyright : (c) Simon Marlow 2003-2006, +-- David Waern 2006-2009, +-- Mark Lentczner 2010 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- + +module Haddock.Backends.Xhtml.Types where + + +-- the base, module and entity URLs for the source code and wiki links. +type SourceURLs = (Maybe String, Maybe String, Maybe String) +type WikiURLs = (Maybe String, Maybe String, Maybe String) + +-- The URL for source and wiki links, and the current module +type LinksInfo = (SourceURLs, WikiURLs) diff --git a/src/Haddock/Backends/Xhtml/Util.hs b/src/Haddock/Backends/Xhtml/Util.hs new file mode 100644 index 00000000..b7f3a8d4 --- /dev/null +++ b/src/Haddock/Backends/Xhtml/Util.hs @@ -0,0 +1,203 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Backends.Html.Util +-- Copyright : (c) Simon Marlow 2003-2006, +-- David Waern 2006-2009, +-- Mark Lentczner 2010 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- + +module Haddock.Backends.Xhtml.Util where + +import Haddock.GhcUtils +import Haddock.Utils + +import Data.Maybe + +import Text.XHtml hiding ( name, title, p, quote ) +import qualified Text.XHtml as Html + +import GHC ( SrcSpan, srcSpanStartLine, Name ) +import Module ( Module ) +import Name ( getOccString, nameOccName, isValOcc ) + + +spliceURL :: Maybe FilePath -> Maybe Module -> Maybe GHC.Name -> + Maybe SrcSpan -> String -> String +spliceURL maybe_file maybe_mod maybe_name maybe_loc url = run url + where + file = fromMaybe "" maybe_file + mdl = case maybe_mod of + Nothing -> "" + Just m -> moduleString m + + (name, kind) = + case maybe_name of + Nothing -> ("","") + Just n | isValOcc (nameOccName n) -> (escapeStr (getOccString n), "v") + | otherwise -> (escapeStr (getOccString n), "t") + + line = case maybe_loc of + Nothing -> "" + Just span_ -> show $ srcSpanStartLine span_ + + run "" = "" + run ('%':'M':rest) = mdl ++ run rest + run ('%':'F':rest) = file ++ run rest + run ('%':'N':rest) = name ++ run rest + run ('%':'K':rest) = kind ++ run rest + run ('%':'L':rest) = line ++ run rest + run ('%':'%':rest) = "%" ++ run rest + + run ('%':'{':'M':'O':'D':'U':'L':'E':'}':rest) = mdl ++ run rest + run ('%':'{':'F':'I':'L':'E':'}':rest) = file ++ run rest + run ('%':'{':'N':'A':'M':'E':'}':rest) = name ++ run rest + run ('%':'{':'K':'I':'N':'D':'}':rest) = kind ++ run rest + + run ('%':'{':'M':'O':'D':'U':'L':'E':'/':'.':'/':c:'}':rest) = + map (\x -> if x == '.' then c else x) mdl ++ run rest + + run ('%':'{':'F':'I':'L':'E':'/':'/':'/':c:'}':rest) = + map (\x -> if x == '/' then c else x) file ++ run rest + + run ('%':'{':'L':'I':'N':'E':'}':rest) = line ++ run rest + + run (c:rest) = c : run rest + + +renderToString :: Html -> String +-- renderToString = showHtml -- for production +renderToString = prettyHtml -- for debugging + +hsep :: [Html] -> Html +hsep [] = noHtml +hsep htmls = foldr1 (\a b -> a+++" "+++b) htmls + +infixr 8 <+>, <++> +(<+>) :: Html -> Html -> Html +a <+> b = a +++ toHtml " " +++ b + +(<++>) :: Html -> Html -> Html +a <++> b = a +++ spaceHtml +++ b + +keyword :: String -> Html +keyword s = thespan ! [theclass "keyword"] << toHtml s + +equals, comma :: Html +equals = char '=' +comma = char ',' + +char :: Char -> Html +char c = toHtml [c] + +empty :: Html +empty = noHtml + + +quote :: Html -> Html +quote h = char '`' +++ h +++ '`' + + +parens, brackets, pabrackets, braces :: Html -> Html +parens h = char '(' +++ h +++ char ')' +brackets h = char '[' +++ h +++ char ']' +pabrackets h = toHtml "[:" +++ h +++ toHtml ":]" +braces h = char '{' +++ h +++ char '}' + +punctuate :: Html -> [Html] -> [Html] +punctuate _ [] = [] +punctuate h (d0:ds) = go d0 ds + where + go d [] = [d] + go d (e:es) = (d +++ h) : go e es + +abovesSep :: HtmlTable -> [HtmlTable] -> HtmlTable +abovesSep _ [] = emptyTable +abovesSep h (d0:ds) = go d0 ds + where + go d [] = d + go d (e:es) = d </> h </> go e es + +parenList :: [Html] -> Html +parenList = parens . hsep . punctuate comma + +ubxParenList :: [Html] -> Html +ubxParenList = ubxparens . hsep . punctuate comma + +ubxparens :: Html -> Html +ubxparens h = toHtml "(#" +++ h +++ toHtml "#)" + + +tda :: [HtmlAttr] -> Html -> HtmlTable +tda as = cell . (td ! as) + +emptyTable :: HtmlTable +emptyTable = cell noHtml + +onclick :: String -> HtmlAttr +onclick = strAttr "onclick" + + +dcolon, arrow, darrow, forallSymbol :: Bool -> Html +dcolon unicode = toHtml (if unicode then "∷" else "::") +arrow unicode = toHtml (if unicode then "→" else "->") +darrow unicode = toHtml (if unicode then "⇒" else "=>") +forallSymbol unicode = if unicode then toHtml "∀" else keyword "forall" + + +dot :: Html +dot = toHtml "." + + +s8 :: HtmlTable +s8 = tda [ theclass "s8" ] << noHtml + + +-- | Generate a named anchor +-- +-- This actually generates two anchor tags, one with the name unescaped, and one +-- with the name URI-escaped. This is needed because Opera 9.52 (and later +-- versions) needs the name to be unescaped, while IE 7 needs it to be escaped. +-- +namedAnchor :: String -> Html -> Html +namedAnchor n c = anchor ! [Html.name n] << noHtml +++ + anchor ! [Html.name (escapeStr n)] << c + + +-- +-- A section of HTML which is collapsible via a +/- button. +-- + +-- TODO: Currently the initial state is non-collapsed. Change the 'minusFile' +-- below to a 'plusFile' and the 'display:block;' to a 'display:none;' when we +-- use cookies from JavaScript to have a more persistent state. + +collapsebutton :: String -> Html +collapsebutton id_ = + image ! [ src minusFile, theclass "coll", onclick ("toggle(this,'" ++ id_ ++ "')"), alt "show/hide" ] + +collapsed :: (HTML a) => (Html -> Html) -> String -> a -> Html +collapsed fn id_ html = + fn ! [identifier id_, thestyle "display:block;"] << html + +-- A quote is a valid part of a Haskell identifier, but it would interfere with +-- the ECMA script string delimiter used in collapsebutton above. +collapseId :: Name -> String +collapseId nm = "i:" ++ escapeStr (getOccString nm) + +linkedAnchor :: String -> Html -> Html +linkedAnchor frag = anchor ! [href hr_] + where hr_ | null frag = "" + | otherwise = '#': escapeStr frag + +documentCharacterEncoding :: Html +documentCharacterEncoding = + meta ! [httpequiv "Content-Type", content "text/html; charset=UTF-8"] + +styleSheet :: Html +styleSheet = + (thelink ! [href cssFile, rel "stylesheet", thetype "text/css"]) noHtml |