diff options
Diffstat (limited to 'src/Haddock/Backends/Html.hs')
| -rw-r--r-- | src/Haddock/Backends/Html.hs | 2008 |
1 files changed, 0 insertions, 2008 deletions
diff --git a/src/Haddock/Backends/Html.hs b/src/Haddock/Backends/Html.hs deleted file mode 100644 index 013f6bc4..00000000 --- a/src/Haddock/Backends/Html.hs +++ /dev/null @@ -1,2008 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Haddock.Backends.Html --- Copyright : (c) Simon Marlow 2003-2006, --- David Waern 2006-2009 --- License : BSD-like --- --- Maintainer : haddock@projects.haskell.org --- Stability : experimental --- Portability : portable ------------------------------------------------------------------------------ -module Haddock.Backends.Html ( - ppHtml, copyHtmlBits, - ppHtmlIndex, ppHtmlContents, - ppHtmlHelpFiles -) where - - -import Prelude hiding (div) - -import Haddock.Backends.DevHelp -import Haddock.Backends.HH -import Haddock.Backends.HH2 -import Haddock.ModuleTree -import Haddock.Types -import Haddock.Version -import Haddock.Utils -import Haddock.Utils.Html hiding ( name, title, p ) -import qualified Haddock.Utils.Html as Html -import Haddock.GhcUtils - -import Control.Exception ( bracket ) -import Control.Monad ( when, unless, join ) -import Data.Char ( toUpper ) -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 System.FilePath hiding ( (</>) ) -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 -import RdrName hiding ( Qual, is_explicit ) -import FastString ( unpackFS ) -import BasicTypes ( IPName(..), Boxity(..) ) -import Outputable ( ppr, showSDoc, Outputable ) - --- 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) - - --- ----------------------------------------------------------------------------- --- 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 = joinPath [libdir, "html"] - css_file = case maybe_css of - Nothing -> joinPath [libhtmldir, cssFile] - Just f -> f - css_destination = joinPath [odir, cssFile] - copyLibFile f = do - copyFile (joinPath [libhtmldir, f]) (joinPath [odir, f]) - copyFile css_file css_destination - mapM_ copyLibFile [ iconFile, plusFile, minusFile, jsFile, framesFile ] - -footer :: HtmlTable -footer = - tda [theclass "botbar"] << - ( toHtml "Produced by" <+> - (anchor ! [href projectUrl] << toHtml projectName) <+> - toHtml ("version " ++ projectVersion) - ) - -srcButton :: SourceURLs -> Maybe Interface -> HtmlTable -srcButton (Just src_base_url, _, _) Nothing = - topButBox (anchor ! [href src_base_url] << toHtml "Source code") - -srcButton (_, Just src_module_url, _) (Just iface) = - let url = spliceURL (Just $ ifaceOrigFilename iface) - (Just $ ifaceMod iface) Nothing Nothing src_module_url - in topButBox (anchor ! [href url] << toHtml "Source code") - -srcButton _ _ = - Html.emptyTable - -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 - -wikiButton :: WikiURLs -> Maybe Module -> HtmlTable -wikiButton (Just wiki_base_url, _, _) Nothing = - topButBox (anchor ! [href wiki_base_url] << toHtml "User Comments") - -wikiButton (_, Just wiki_module_url, _) (Just mdl) = - let url = spliceURL Nothing (Just mdl) Nothing Nothing wiki_module_url - in topButBox (anchor ! [href url] << toHtml "User Comments") - -wikiButton _ _ = - Html.emptyTable - -contentsButton :: Maybe String -> HtmlTable -contentsButton maybe_contents_url - = topButBox (anchor ! [href url] << toHtml "Contents") - where url = maybe contentsHtmlFile id maybe_contents_url - -indexButton :: Maybe String -> HtmlTable -indexButton maybe_index_url - = topButBox (anchor ! [href url] << toHtml "Index") - where url = maybe indexHtmlFile id maybe_index_url - -simpleHeader :: String -> Maybe String -> Maybe String - -> SourceURLs -> WikiURLs -> HtmlTable -simpleHeader doctitle maybe_contents_url maybe_index_url - maybe_source_url maybe_wiki_url = - (tda [theclass "topbar"] << - vanillaTable << ( - (td << - image ! [src "haskell_icon.gif", width "16", height 16, alt " " ] - ) <-> - (tda [theclass "title"] << toHtml doctitle) <-> - srcButton maybe_source_url Nothing <-> - wikiButton maybe_wiki_url Nothing <-> - contentsButton maybe_contents_url <-> indexButton maybe_index_url - )) - -pageHeader :: String -> Interface -> String - -> SourceURLs -> WikiURLs - -> Maybe String -> Maybe String -> HtmlTable -pageHeader mdl iface doctitle - maybe_source_url maybe_wiki_url - maybe_contents_url maybe_index_url = - (tda [theclass "topbar"] << - vanillaTable << ( - (td << - image ! [src "haskell_icon.gif", width "16", height 16, alt " "] - ) <-> - (tda [theclass "title"] << toHtml doctitle) <-> - srcButton maybe_source_url (Just iface) <-> - wikiButton maybe_wiki_url (Just $ ifaceMod iface) <-> - contentsButton maybe_contents_url <-> - indexButton maybe_index_url - ) - ) </> - tda [theclass "modulebar"] << - (vanillaTable << ( - (td << font ! [size "6"] << toHtml mdl) <-> - moduleInfo iface - ) - ) - -moduleInfo :: Interface -> HtmlTable -moduleInfo iface = - let - info = ifaceInfo iface - - doOneEntry :: (String, (HaddockModInfo GHC.Name) -> Maybe String) -> Maybe HtmlTable - doOneEntry (fieldName,field) = case field info of - Nothing -> Nothing - Just fieldValue -> - Just ((tda [theclass "infohead"] << toHtml fieldName) - <-> (tda [theclass "infoval"]) << toHtml fieldValue) - - entries :: [HtmlTable] - entries = mapMaybe doOneEntry [ - ("Portability",hmi_portability), - ("Stability",hmi_stability), - ("Maintainer",hmi_maintainer) - ] - in - case entries of - [] -> Html.emptyTable - _ -> tda [align "right"] << narrowTable << (foldl1 (</>) entries) - --- --------------------------------------------------------------------------- --- 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 << vanillaTable << ( - simpleHeader doctitle Nothing maybe_index_url - maybe_source_url maybe_wiki_url </> - ppPrologue doctitle prologue </> - ppModuleTree doctitle tree </> - s15 </> - footer - ) - createDirectoryIfMissing True odir - writeFile (joinPath [odir, contentsHtmlFile]) (renderHtml 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 = Html.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 -> 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__ - --- The URL for source and wiki links, and the current module -type LinksInfo = (SourceURLs, WikiURLs) - --- | 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 (joinPath [odir, frameIndexHtmlFile]) (renderHtml 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 << vanillaTable << ( - simpleHeader doctitle maybe_contents_url Nothing - maybe_source_url maybe_wiki_url </> - index_html - ) - - createDirectoryIfMissing True odir - - when split_indices $ - mapM_ (do_sub_index index) initialChars - - writeFile (joinPath [odir, indexHtmlFile]) (renderHtml 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 = - 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 (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 (joinPath [odir, subIndexHtmlFile c]) (renderHtml html) - where - html = header (documentCharacterEncoding +++ - thetitle (toHtml (doctitle ++ " (Index)")) +++ - styleSheet) +++ - body << vanillaTable << ( - simpleHeader doctitle maybe_contents_url Nothing - maybe_source_url maybe_wiki_url </> - 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? - << Html [HtmlString ("window.onload = function () {setSynopsis(\"mini_" - ++ moduleHtmlFile mdl ++ "\")};")]) - ) +++ - body << vanillaTable << ( - pageHeader mdl_str iface doctitle - maybe_source_url maybe_wiki_url - maybe_contents_url maybe_index_url </> s15 </> - ifaceToHtml maybe_source_url maybe_wiki_url iface unicode </> s15 </> - footer - ) - createDirectoryIfMissing True odir - writeFile (joinPath [odir, moduleHtmlFile mdl]) (renderHtml 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 (joinPath [odir, "mini_" ++ moduleHtmlFile mdl]) (renderHtml html) - -ifaceToHtml :: SourceURLs -> WikiURLs -> Interface -> Bool -> HtmlTable -ifaceToHtml maybe_source_url maybe_wiki_url iface unicode - = abovesSep s15 (contents ++ 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) - - contents = case ppModuleContents exports of - Nothing -> [] - Just x -> [td << vanillaTable << x] - - description - = case ifaceRnDoc iface of - Nothing -> Html.emptyTable - Just doc -> (tda [theclass "section1"] << toHtml "Description") </> - docBox (docToHtml doc) - - -- omit the synopsis if there are no documentation annotations at all - synopsis - | no_doc_at_all = Html.emptyTable - | otherwise - = (tda [theclass "section1"] << toHtml "Synopsis") </> - s15 </> - (tda [theclass "body"] << vanillaTable << - abovesSep s8 (map (processExport True linksInfo unicode) - (filter forSummary exports)) - ) - - -- if the documentation doesn't begin with a section header, then - -- add one ("Documentation"). - maybe_doc_hdr - = case exports of - [] -> Html.emptyTable - ExportGroup _ _ _ : _ -> Html.emptyTable - _ -> tda [ theclass "section1" ] << toHtml "Documentation" - - bdy = 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 (moduleNameUrl mdl 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] -> Maybe HtmlTable -ppModuleContents exports - | length sections == 0 = Nothing - | otherwise = Just (tda [theclass "section4"] << bold << toHtml "Contents" - </> td << dlist << concatHtml sections) - where - (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 = (dterm << 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 = ddef << dlist << concatHtml 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) -> HtmlTable -processExport _ _ _ (ExportGroup lev id0 doc) - = ppDocGroup lev (namedAnchor id0 << docToHtml doc) -processExport summary links unicode (ExportDecl decl doc subdocs insts) - = ppDecl summary links decl doc insts subdocs unicode -processExport _ _ _ (ExportNoDecl y []) - = declBox (ppDocName y) -processExport _ _ _ (ExportNoDecl y subs) - = declBox (ppDocName y <+> parenList (map ppDocName subs)) -processExport _ _ _ (ExportDoc doc) - = docBox (docToHtml doc) -processExport _ _ _ (ExportModule mdl) - = declBox (toHtml "module" <+> ppModule mdl "") - -forSummary :: (ExportItem DocName) -> Bool -forSummary (ExportGroup _ _ _) = False -forSummary (ExportDoc _) = False -forSummary _ = True - -ppDocGroup :: Int -> Html -> HtmlTable -ppDocGroup lev doc - | lev == 1 = tda [ theclass "section1" ] << doc - | lev == 2 = tda [ theclass "section2" ] << doc - | lev == 3 = tda [ theclass "section3" ] << doc - | otherwise = tda [ theclass "section4" ] << doc - -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) - - --- TODO: use DeclInfo DocName or something -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 _ -> Html.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 -> Html.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 -> Html.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 -> Html.emptyTable - Just d -> ndocBox (docToHtml d) - - body_ - | null lsigs, null ats = Html.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 = Html.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 -> Html.emptyTable - - constrBit - | null cons = Html.emptyTable - | otherwise = constrHdr </> ( - tda [theclass "body"] << constrTable << - aboves (map (ppSideBySideConstr subdocs unicode) cons) - ) - - instId = collapseId (getName docname) - - instancesBit - | null instances = Html.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 -#if __GLASGOW_HASKELL__ == 612 -ppConstrHdr :: HsExplicitForAll -> [Name] -> HsContext DocName -> Bool -> Html -#else -ppConstrHdr :: HsExplicitFlag -> [Name] -> HsContext DocName -> Bool -> Html -#endif -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 = Html.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 _ = toHtml "!" -- Unpacked args is an implementation detail, - -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 - -#if __GLASGOW_HASKELL__ == 612 -ppForAll :: HsExplicitForAll -> [Located (HsTyVarBndr DocName)] -#else -ppForAll :: HsExplicitFlag -> [Located (HsTyVarBndr DocName)] -#endif - -> 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] - -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" -#if __GLASGOW_HASKELL__ == 612 -ppr_mono_ty _ (HsSpliceTyOut {}) _ = error "ppr_mono_ty HsQuasiQuoteTy" -#else -ppr_mono_ty _ (HsQuasiQuoteTy {}) _ = error "ppr_mono_ty HsQuasiQuoteTy" -#endif -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] - - --- ---------------------------------------------------------------------------- --- Names - -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 (nameAnchorId 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 (nameAnchorId 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 -> moduleUrl mdl - Just name -> moduleNameUrl mdl name - -ppModule :: Module -> String -> Html -ppModule mdl ref = anchor ! [href ((moduleHtmlFile mdl) ++ ref)] - << toHtml (moduleString mdl) - --- ----------------------------------------------------------------------------- --- * Doc Markup - -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 "", - markupExample = examplesToHtml - } - 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 - - examplesToHtml l = (pre $ concatHtml $ map exampleToHtml l) ! [theclass "screen"] - - exampleToHtml (Example expression result) = htmlExample - where - htmlExample = htmlPrompt +++ htmlExpression +++ (toHtml $ unlines result) - htmlPrompt = (thecode . toHtml $ "ghci> ") ! [theclass "prompt"] - htmlExpression = (strong . thecode . toHtml $ expression ++ "\n") ! [theclass "userinput"] - - -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 (unParagraph (markup htmlCleanup doc)) - -origDocToHtml :: Doc Name -> Html -origDocToHtml doc = markup htmlOrigMarkup (unParagraph (markup htmlCleanup doc)) - -rdrDocToHtml :: Doc RdrName -> Html -rdrDocToHtml doc = markup htmlRdrMarkup (unParagraph (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 - } - --- ----------------------------------------------------------------------------- --- * Misc - - -hsep :: [Html] -> Html -hsep [] = noHtml -hsep htmls = foldr1 (\a b -> a+++" "+++b) htmls - -infixr 8 <+>, <++> -(<+>) :: Html -> Html -> Html -a <+> b = Html (getHtmlElements (toHtml a) ++ HtmlString " ": getHtmlElements (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 _ [] = Html.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 "#)" - -{- -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 -> Html.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 -> Html.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) - --- a box for the buttons at the top of the page -topButBox :: Html -> HtmlTable -topButBox html = tda [theclass "topbut"] << html - -bodyBox :: Html -> HtmlTable -bodyBox html = tda [theclass "body"] << vanillaTable << html - --- a vanilla table has width 100%, no border, no padding, no spacing --- a narrow table is the same but without width 100%. -vanillaTable, vanillaTable2, narrowTable :: Html -> Html -vanillaTable = table ! [theclass "vanilla", cellspacing 0, cellpadding 0] -vanillaTable2 = table ! [theclass "vanilla2", cellspacing 0, cellpadding 0] -narrowTable = table ! [theclass "narrow", 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") - -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, s15 :: HtmlTable -s8 = tda [ theclass "s8" ] << noHtml -s15 = tda [ theclass "s15" ] << 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 = (anchor ! [Html.name n]) . (anchor ! [Html.name (escapeStr n)]) - - --- --- 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"] |