diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Haddock/Backends/Html.hs | 2008 | ||||
| -rw-r--r-- | src/Haddock/Options.hs | 6 | ||||
| -rw-r--r-- | src/Haddock/Utils/BlockTable.hs | 180 | ||||
| -rw-r--r-- | src/Haddock/Utils/Html.hs | 1037 | ||||
| -rw-r--r-- | src/Main.hs | 15 |
5 files changed, 5 insertions, 3241 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"] diff --git a/src/Haddock/Options.hs b/src/Haddock/Options.hs index f2718e86..53b9337d 100644 --- a/src/Haddock/Options.hs +++ b/src/Haddock/Options.hs @@ -57,7 +57,6 @@ data Flag | Flag_WikiBaseURL String | Flag_WikiModuleURL String | Flag_WikiEntityURL String - | Flag_Xhtml | Flag_LaTeX | Flag_LaTeXStyle String | Flag_Help @@ -94,9 +93,8 @@ options backwardsCompat = "write the resulting interface to FILE", -- Option ['S'] ["docbook"] (NoArg Flag_DocBook) -- "output in DocBook XML", - Option ['h'] ["html"] (NoArg Flag_Html) - "output in HTML", - Option [] ["xhtml"] (NoArg Flag_Xhtml) "use experimental XHTML rendering", + Option ['h'] ["html", "xhtml"] (NoArg Flag_Html) + "output in HTML (XHTML 1.0)", Option [] ["latex"] (NoArg Flag_LaTeX) "use experimental LaTeX rendering", Option [] ["latex-style"] (ReqArg Flag_LaTeXStyle "FILE") "provide your own LaTeX style in FILE", Option ['U'] ["use-unicode"] (NoArg Flag_UseUnicode) "use Unicode in HTML output", diff --git a/src/Haddock/Utils/BlockTable.hs b/src/Haddock/Utils/BlockTable.hs deleted file mode 100644 index 7bd9b973..00000000 --- a/src/Haddock/Utils/BlockTable.hs +++ /dev/null @@ -1,180 +0,0 @@ -{- | - - Module : Text.Html.BlockTable - Copyright : (c) Andy Gill, and the Oregon Graduate Institute of - Science and Technology, 1999-2001 - License : BSD-style (see the file libraries/core/LICENSE) - - Maintainer : Andy Gill <andy@galconn.com> - Stability : experimental - Portability : portable - - $Id: BlockTable.hs,v 1.2 2002/07/24 09:42:18 simonmar Exp $ - - An Html combinator library - --} - -module Haddock.Utils.BlockTable ( - --- Datatypes: - - BlockTable, -- abstract - --- Contruction Functions: - - single, - empty, - above, - beside, - --- Investigation Functions: - - getMatrix, - showsTable, - showTable, - - ) where - -import Prelude - -infixr 4 `beside` -infixr 3 `above` - --- These combinators can be used to build formated 2D tables. --- The specific target useage is for HTML table generation. - -{- - Examples of use: - - > table1 :: BlockTable String - > table1 = single "Hello" +-----+ - |Hello| - This is a 1x1 cell +-----+ - Note: single has type - - single :: a -> BlockTable a - - So the cells can contain anything. - - > table2 :: BlockTable String - > table2 = single "World" +-----+ - |World| - +-----+ - - - > table3 :: BlockTable String - > table3 = table1 %-% table2 +-----%-----+ - |Hello%World| - % is used to indicate +-----%-----+ - the join edge between - the two Tables. - - > table4 :: BlockTable String - > table4 = table3 %/% table2 +-----+-----+ - |Hello|World| - Notice the padding on the %%%%%%%%%%%%% - smaller (bottom) cell to |World | - force the table to be a +-----------+ - rectangle. - - > table5 :: BlockTable String - > table5 = table1 %-% table4 +-----%-----+-----+ - |Hello%Hello|World| - Notice the padding on the | %-----+-----+ - leftmost cell, again to | %World | - force the table to be a +-----%-----------+ - rectangle. - - Now the table can be rendered with processTable, for example: - Main> processTable table5 - [[("Hello",(1,2)), - ("Hello",(1,1)), - ("World",(1,1))], - [("World",(2,1))]] :: [[([Char],(Int,Int))]] - Main> --} - --- --------------------------------------------------------------------------- --- Contruction Functions - --- Perhaps one day I'll write the Show instance --- to show boxes aka the above ascii renditions. - -instance (Show a) => Show (BlockTable a) where - showsPrec _ = showsTable - -type TableI a = [[(a,(Int,Int))]] -> [[(a,(Int,Int))]] - -data BlockTable a = Table (Int -> Int -> TableI a) Int Int - - --- You can create a (1x1) table entry - -single :: a -> BlockTable a -single a = Table (\ x y r -> [(a,(x+1,y+1))] : r) 1 1 - -empty :: BlockTable a -empty = Table (\ _ _ r -> r) 0 0 - - --- You can compose tables, horizonally and vertically - -above :: BlockTable a -> BlockTable a -> BlockTable a -beside :: BlockTable a -> BlockTable a -> BlockTable a - -t1 `above` t2 = trans (combine (trans t1) (trans t2) (.)) - -t1 `beside` t2 = combine t1 t2 (\ lst1 lst2 r -> - let - -- Note this depends on the fact that - -- that the result has the same number - -- of lines as the y dimention; one list - -- per line. This is not true in general - -- but is always true for these combinators. - -- I should assert this! - -- I should even prove this. - beside' (x:xs) (y:ys) = (x ++ y) : beside' xs ys - beside' (x:xs) [] = x : xs ++ r - beside' [] (y:ys) = y : ys ++ r - beside' [] [] = r - in - beside' (lst1 []) (lst2 [])) - --- trans flips (transposes) over the x and y axis of --- the table. It is only used internally, and typically --- in pairs, ie. (flip ... munge ... (un)flip). - -trans :: BlockTable a -> BlockTable a -trans (Table f1 x1 y1) = Table (flip f1) y1 x1 - -combine :: BlockTable a - -> BlockTable b - -> (TableI a -> TableI b -> TableI c) - -> BlockTable c -combine (Table f1 x1 y1) (Table f2 x2 y2) comb = Table new_fn (x1+x2) max_y - where - max_y = max y1 y2 - new_fn x y = - case compare y1 y2 of - EQ -> comb (f1 0 y) (f2 x y) - GT -> comb (f1 0 y) (f2 x (y + y1 - y2)) - LT -> comb (f1 0 (y + y2 - y1)) (f2 x y) - --- --------------------------------------------------------------------------- --- Investigation Functions - --- This is the other thing you can do with a Table; --- turn it into a 2D list, tagged with the (x,y) --- sizes of each cell in the table. - -getMatrix :: BlockTable a -> [[(a,(Int,Int))]] -getMatrix (Table r _ _) = r 0 0 [] - --- You can also look at a table - -showsTable :: (Show a) => BlockTable a -> ShowS -showsTable table = shows (getMatrix table) - -showTable :: (Show a) => BlockTable a -> String -showTable table = showsTable table "" diff --git a/src/Haddock/Utils/Html.hs b/src/Haddock/Utils/Html.hs deleted file mode 100644 index dbef2112..00000000 --- a/src/Haddock/Utils/Html.hs +++ /dev/null @@ -1,1037 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : Text.Html --- Copyright : (c) Andy Gill, and the Oregon Graduate Institute of --- Science and Technology, 1999-2001 --- License : BSD-style (see the file libraries/core/LICENSE) --- --- Maintainer : Andy Gill <andy@galconn.com> --- Stability : experimental --- Portability : portable --- --- An Html combinator library --- ------------------------------------------------------------------------------ - -module Haddock.Utils.Html ( - module Haddock.Utils.Html, - ) where - -import qualified Haddock.Utils.BlockTable as BT - -import Data.Char (isAscii, ord) -import Numeric (showHex) - -infixr 2 +++ -- combining Html -infixr 7 << -- nesting Html -infixl 8 ! -- adding optional arguments - - --- A important property of Html is that all strings inside the --- structure are already in Html friendly format. --- For example, use of >,etc. - -data HtmlElement -{- - - ..just..plain..normal..text... but using © and &amb;, etc. - -} - = HtmlString String -{- - - <thetag {..attrs..}> ..content.. </thetag> - -} - | HtmlTag { -- tag with internal markup - markupTag :: String, - markupAttrs :: [HtmlAttr], - markupContent :: Html - } - -{- These are the index-value pairs. - - The empty string is a synonym for tags with no arguments. - - (not strictly HTML, but anyway). - -} - - -data HtmlAttr = HtmlAttr String String - - -newtype Html = Html { getHtmlElements :: [HtmlElement] } - --- Read MARKUP as the class of things that can be validly rendered --- inside MARKUP tag brackets. So this can be one or more Html's, --- or a String, for example. - -class HTML a where - toHtml :: a -> Html - toHtmlFromList :: [a] -> Html - - toHtmlFromList xs = Html (concat [ x | (Html x) <- map toHtml xs]) - -instance HTML Html where - toHtml a = a - -instance HTML Char where - toHtml a = toHtml [a] - toHtmlFromList [] = Html [] - toHtmlFromList str = Html [HtmlString (stringToHtmlString str)] - -instance (HTML a) => HTML [a] where - toHtml xs = toHtmlFromList xs - -class ADDATTRS a where - (!) :: a -> [HtmlAttr] -> a - -instance (ADDATTRS b) => ADDATTRS (a -> b) where - (!) fn attr = \ arg -> fn arg ! attr - -instance ADDATTRS Html where - (!) (Html htmls) attr = Html (map addAttrs htmls) - where - addAttrs html = - case html of - HtmlTag { markupAttrs = markupAttrs0 - , markupTag = markupTag0 - , markupContent = markupContent0 } -> - HtmlTag { markupAttrs = markupAttrs0 ++ attr - , markupTag = markupTag0 - , markupContent = markupContent0 } - _ -> html - - -(<<) :: (HTML a) => (Html -> b) -> a -> b -fn << arg = fn (toHtml arg) - - -concatHtml :: (HTML a) => [a] -> Html -concatHtml as = Html (concat (map (getHtmlElements.toHtml) as)) - -(+++) :: (HTML a,HTML b) => a -> b -> Html -a +++ b = Html (getHtmlElements (toHtml a) ++ getHtmlElements (toHtml b)) - -noHtml :: Html -noHtml = Html [] - - -isNoHtml :: Html -> Bool -isNoHtml (Html xs) = null xs - - -tag :: String -> Html -> Html -tag str htmls = - Html [ HtmlTag { markupTag = str, - markupAttrs = [], - markupContent = htmls } - ] - -itag :: String -> Html -itag str = tag str noHtml - -emptyAttr :: String -> HtmlAttr -emptyAttr s = HtmlAttr s "" - -intAttr :: String -> Int -> HtmlAttr -intAttr s i = HtmlAttr s (show i) - -strAttr :: String -> String -> HtmlAttr -strAttr s t = HtmlAttr s t - - -{- -foldHtml :: (String -> [HtmlAttr] -> [a] -> a) - -> (String -> a) - -> Html - -> a -foldHtml f g (HtmlTag str attr fmls) - = f str attr (map (foldHtml f g) fmls) -foldHtml f g (HtmlString str) - = g str - --} --- Processing Strings into Html friendly things. --- This converts a String to a Html String. -stringToHtmlString :: String -> String -stringToHtmlString = concatMap fixChar - where - fixChar '<' = "<" - fixChar '>' = ">" - fixChar '&' = "&" - fixChar '"' = """ - fixChar c - | isAscii c = [c] - | otherwise = "&#x" ++ showHex (ord c) ";" - --- --------------------------------------------------------------------------- --- Classes - -instance Show Html where - showsPrec _ html = showString (prettyHtml html) - showList htmls = showString (concat (map show htmls)) - -instance Show HtmlAttr where - showsPrec _ (HtmlAttr str val) = - showString str . - showString "=" . - shows val - - --- --------------------------------------------------------------------------- --- Data types - -type URL = String - --- --------------------------------------------------------------------------- --- Basic primitives - --- This is not processed for special chars. --- use stringToHtml or lineToHtml instead, for user strings, --- because they understand special chars, like '<'. - -primHtml :: String -> Html -primHtml x = Html [HtmlString x] - --- --------------------------------------------------------------------------- --- Basic Combinators - -stringToHtml :: String -> Html -stringToHtml = primHtml . stringToHtmlString - --- This converts a string, but keeps spaces as non-line-breakable - -lineToHtml :: String -> Html -lineToHtml = primHtml . concatMap htmlizeChar2 . stringToHtmlString - where - htmlizeChar2 ' ' = " " - htmlizeChar2 c = [c] - --- --------------------------------------------------------------------------- --- Html Constructors - --- (automatically generated) - -address :: Html -> Html -anchor :: Html -> Html -applet :: Html -> Html -area :: Html -basefont :: Html -big :: Html -> Html -blockquote :: Html -> Html -body :: Html -> Html -bold :: Html -> Html -br :: Html -button :: Html -> Html -caption :: Html -> Html -center :: Html -> Html -cite :: Html -> Html -ddef :: Html -> Html -define :: Html -> Html -dlist :: Html -> Html -dterm :: Html -> Html -emphasize :: Html -> Html -fieldset :: Html -> Html -font :: Html -> Html -form :: Html -> Html -frame :: Html -> Html -frameset :: Html -> Html -h1 :: Html -> Html -h2 :: Html -> Html -h3 :: Html -> Html -h4 :: Html -> Html -h5 :: Html -> Html -h6 :: Html -> Html -header :: Html -> Html -hr :: Html -image :: Html -input :: Html -italics :: Html -> Html -keyboard :: Html -> Html -legend :: Html -> Html -li :: Html -> Html -meta :: Html -noframes :: Html -> Html -olist :: Html -> Html -option :: Html -> Html -paragraph :: Html -> Html -param :: Html -pre :: Html -> Html -sample :: Html -> Html -script :: Html -> Html -select :: Html -> Html -small :: Html -> Html -strong :: Html -> Html -style :: Html -> Html -sub :: Html -> Html -sup :: Html -> Html -table :: Html -> Html -thetd :: Html -> Html -textarea :: Html -> Html -th :: Html -> Html -thebase :: Html -thecode :: Html -> Html -thediv :: Html -> Html -thehtml :: Html -> Html -thelink :: Html -themap :: Html -> Html -thespan :: Html -> Html -thetitle :: Html -> Html -tr :: Html -> Html -tt :: Html -> Html -ulist :: Html -> Html -underline :: Html -> Html -variable :: Html -> Html - -address = tag "ADDRESS" -anchor = tag "A" -applet = tag "APPLET" -area = itag "AREA" -basefont = itag "BASEFONT" -big = tag "BIG" -blockquote = tag "BLOCKQUOTE" -body = tag "BODY" -bold = tag "B" -br = itag "BR" -button = tag "BUTTON" -caption = tag "CAPTION" -center = tag "CENTER" -cite = tag "CITE" -ddef = tag "DD" -define = tag "DFN" -dlist = tag "DL" -dterm = tag "DT" -emphasize = tag "EM" -fieldset = tag "FIELDSET" -font = tag "FONT" -form = tag "FORM" -frame = tag "FRAME" -frameset = tag "FRAMESET" -h1 = tag "H1" -h2 = tag "H2" -h3 = tag "H3" -h4 = tag "H4" -h5 = tag "H5" -h6 = tag "H6" -header = tag "HEAD" -hr = itag "HR" -image = itag "IMG" -input = itag "INPUT" -italics = tag "I" -keyboard = tag "KBD" -legend = tag "LEGEND" -li = tag "LI" -meta = itag "META" -noframes = tag "NOFRAMES" -olist = tag "OL" -option = tag "OPTION" -paragraph = tag "P" -param = itag "PARAM" -pre = tag "PRE" -sample = tag "SAMP" -script = tag "SCRIPT" -select = tag "SELECT" -small = tag "SMALL" -strong = tag "STRONG" -style = tag "STYLE" -sub = tag "SUB" -sup = tag "SUP" -table = tag "TABLE" -thetd = tag "TD" -textarea = tag "TEXTAREA" -th = tag "TH" -thebase = itag "BASE" -thecode = tag "CODE" -thediv = tag "DIV" -thehtml = tag "HTML" -thelink = itag "LINK" -themap = tag "MAP" -thespan = tag "SPAN" -thetitle = tag "TITLE" -tr = tag "TR" -tt = tag "TT" -ulist = tag "UL" -underline = tag "U" -variable = tag "VAR" - --- --------------------------------------------------------------------------- --- Html Attributes - --- (automatically generated) - -action :: String -> HtmlAttr -align :: String -> HtmlAttr -alink :: String -> HtmlAttr -alt :: String -> HtmlAttr -altcode :: String -> HtmlAttr -archive :: String -> HtmlAttr -background :: String -> HtmlAttr -base :: String -> HtmlAttr -bgcolor :: String -> HtmlAttr -border :: Int -> HtmlAttr -bordercolor :: String -> HtmlAttr -cellpadding :: Int -> HtmlAttr -cellspacing :: Int -> HtmlAttr -checked :: HtmlAttr -clear :: String -> HtmlAttr -code :: String -> HtmlAttr -codebase :: String -> HtmlAttr -color :: String -> HtmlAttr -cols :: String -> HtmlAttr -colspan :: Int -> HtmlAttr -compact :: HtmlAttr -content :: String -> HtmlAttr -coords :: String -> HtmlAttr -enctype :: String -> HtmlAttr -face :: String -> HtmlAttr -frameborder :: Int -> HtmlAttr -height :: Int -> HtmlAttr -href :: String -> HtmlAttr -hspace :: Int -> HtmlAttr -httpequiv :: String -> HtmlAttr -identifier :: String -> HtmlAttr -ismap :: HtmlAttr -lang :: String -> HtmlAttr -link :: String -> HtmlAttr -marginheight :: Int -> HtmlAttr -marginwidth :: Int -> HtmlAttr -maxlength :: Int -> HtmlAttr -method :: String -> HtmlAttr -multiple :: HtmlAttr -name :: String -> HtmlAttr -nohref :: HtmlAttr -noresize :: HtmlAttr -noshade :: HtmlAttr -nowrap :: HtmlAttr -onclick :: String -> HtmlAttr -rel :: String -> HtmlAttr -rev :: String -> HtmlAttr -rows :: String -> HtmlAttr -rowspan :: Int -> HtmlAttr -rules :: String -> HtmlAttr -scrolling :: String -> HtmlAttr -selected :: HtmlAttr -shape :: String -> HtmlAttr -size :: String -> HtmlAttr -src :: String -> HtmlAttr -start :: Int -> HtmlAttr -target :: String -> HtmlAttr -text :: String -> HtmlAttr -theclass :: String -> HtmlAttr -thestyle :: String -> HtmlAttr -thetype :: String -> HtmlAttr -title :: String -> HtmlAttr -usemap :: String -> HtmlAttr -valign :: String -> HtmlAttr -value :: String -> HtmlAttr -version :: String -> HtmlAttr -vlink :: String -> HtmlAttr -vspace :: Int -> HtmlAttr -width :: String -> HtmlAttr - -action = strAttr "ACTION" -align = strAttr "ALIGN" -alink = strAttr "ALINK" -alt = strAttr "ALT" -altcode = strAttr "ALTCODE" -archive = strAttr "ARCHIVE" -background = strAttr "BACKGROUND" -base = strAttr "BASE" -bgcolor = strAttr "BGCOLOR" -border = intAttr "BORDER" -bordercolor = strAttr "BORDERCOLOR" -cellpadding = intAttr "CELLPADDING" -cellspacing = intAttr "CELLSPACING" -checked = emptyAttr "CHECKED" -clear = strAttr "CLEAR" -code = strAttr "CODE" -codebase = strAttr "CODEBASE" -color = strAttr "COLOR" -cols = strAttr "COLS" -colspan = intAttr "COLSPAN" -compact = emptyAttr "COMPACT" -content = strAttr "CONTENT" -coords = strAttr "COORDS" -enctype = strAttr "ENCTYPE" -face = strAttr "FACE" -frameborder = intAttr "FRAMEBORDER" -height = intAttr "HEIGHT" -href = strAttr "HREF" -hspace = intAttr "HSPACE" -httpequiv = strAttr "HTTP-EQUIV" -identifier = strAttr "ID" -ismap = emptyAttr "ISMAP" -lang = strAttr "LANG" -link = strAttr "LINK" -marginheight = intAttr "MARGINHEIGHT" -marginwidth = intAttr "MARGINWIDTH" -maxlength = intAttr "MAXLENGTH" -method = strAttr "METHOD" -multiple = emptyAttr "MULTIPLE" -name = strAttr "NAME" -nohref = emptyAttr "NOHREF" -noresize = emptyAttr "NORESIZE" -noshade = emptyAttr "NOSHADE" -nowrap = emptyAttr "NOWRAP" -onclick = strAttr "ONCLICK" -rel = strAttr "REL" -rev = strAttr "REV" -rows = strAttr "ROWS" -rowspan = intAttr "ROWSPAN" -rules = strAttr "RULES" -scrolling = strAttr "SCROLLING" -selected = emptyAttr "SELECTED" -shape = strAttr "SHAPE" -size = strAttr "SIZE" -src = strAttr "SRC" -start = intAttr "START" -target = strAttr "TARGET" -text = strAttr "TEXT" -theclass = strAttr "CLASS" -thestyle = strAttr "STYLE" -thetype = strAttr "TYPE" -title = strAttr "TITLE" -usemap = strAttr "USEMAP" -valign = strAttr "VALIGN" -value = strAttr "VALUE" -version = strAttr "VERSION" -vlink = strAttr "VLINK" -vspace = intAttr "VSPACE" -width = strAttr "WIDTH" - --- --------------------------------------------------------------------------- --- Html Constructors - --- (automatically generated) - -validHtmlTags :: [String] -validHtmlTags = [ - "ADDRESS", - "A", - "APPLET", - "BIG", - "BLOCKQUOTE", - "BODY", - "B", - "CAPTION", - "CENTER", - "CITE", - "DD", - "DFN", - "DL", - "DT", - "EM", - "FIELDSET", - "FONT", - "FORM", - "FRAME", - "FRAMESET", - "H1", - "H2", - "H3", - "H4", - "H5", - "H6", - "HEAD", - "I", - "KBD", - "LEGEND", - "LI", - "NOFRAMES", - "OL", - "OPTION", - "P", - "PRE", - "SAMP", - "SELECT", - "SMALL", - "STRONG", - "STYLE", - "SUB", - "SUP", - "TABLE", - "TD", - "TEXTAREA", - "TH", - "CODE", - "DIV", - "HTML", - "LINK", - "MAP", - "TITLE", - "TR", - "TT", - "UL", - "U", - "VAR"] - -validHtmlITags :: [String] -validHtmlITags = [ - "AREA", - "BASEFONT", - "BR", - "HR", - "IMG", - "INPUT", - "LINK", - "META", - "PARAM", - "BASE"] - -validHtmlAttrs :: [String] -validHtmlAttrs = [ - "ACTION", - "ALIGN", - "ALINK", - "ALT", - "ALTCODE", - "ARCHIVE", - "BACKGROUND", - "BASE", - "BGCOLOR", - "BORDER", - "BORDERCOLOR", - "CELLPADDING", - "CELLSPACING", - "CHECKED", - "CLEAR", - "CODE", - "CODEBASE", - "COLOR", - "COLS", - "COLSPAN", - "COMPACT", - "CONTENT", - "COORDS", - "ENCTYPE", - "FACE", - "FRAMEBORDER", - "HEIGHT", - "HREF", - "HSPACE", - "HTTP-EQUIV", - "ID", - "ISMAP", - "LANG", - "LINK", - "MARGINHEIGHT", - "MARGINWIDTH", - "MAXLENGTH", - "METHOD", - "MULTIPLE", - "NAME", - "NOHREF", - "NORESIZE", - "NOSHADE", - "NOWRAP", - "REL", - "REV", - "ROWS", - "ROWSPAN", - "RULES", - "SCROLLING", - "SELECTED", - "SHAPE", - "SIZE", - "SRC", - "START", - "TARGET", - "TEXT", - "CLASS", - "STYLE", - "TYPE", - "TITLE", - "USEMAP", - "VALIGN", - "VALUE", - "VERSION", - "VLINK", - "VSPACE", - "WIDTH"] - --- --------------------------------------------------------------------------- --- Html colors - -aqua :: String -black :: String -blue :: String -fuchsia :: String -gray :: String -green :: String -lime :: String -maroon :: String -navy :: String -olive :: String -purple :: String -red :: String -silver :: String -teal :: String -yellow :: String -white :: String - -aqua = "aqua" -black = "black" -blue = "blue" -fuchsia = "fuchsia" -gray = "gray" -green = "green" -lime = "lime" -maroon = "maroon" -navy = "navy" -olive = "olive" -purple = "purple" -red = "red" -silver = "silver" -teal = "teal" -yellow = "yellow" -white = "white" - --- --------------------------------------------------------------------------- --- Basic Combinators - -linesToHtml :: [String] -> Html - -linesToHtml [] = noHtml -linesToHtml (x:[]) = lineToHtml x -linesToHtml (x:xs) = lineToHtml x +++ br +++ linesToHtml xs - - --- --------------------------------------------------------------------------- --- Html abbriviations - -primHtmlChar :: String -> Html -copyright :: Html -spaceHtml :: Html -bullet :: Html -p :: Html -> Html - -primHtmlChar = \ x -> primHtml ("&" ++ x ++ ";") -copyright = primHtmlChar "copy" -spaceHtml = primHtmlChar "nbsp" -bullet = primHtmlChar "#149" - -p = paragraph - --- --------------------------------------------------------------------------- --- Html tables - -cell :: Html -> HtmlTable -cell h = let - cellFn x y = h ! (add x colspan $ add y rowspan $ []) - add 1 _ rest = rest - add n fn rest = fn n : rest - r = BT.single cellFn - in - mkHtmlTable r - --- We internally represent the Cell inside a Table with an --- object of the type --- \pre{ --- Int -> Int -> Html --- } --- When we render it later, we find out how many columns --- or rows this cell will span over, and can --- include the correct colspan/rowspan command. - -newtype HtmlTable - = HtmlTable (BT.BlockTable (Int -> Int -> Html)) - -td :: Html -> HtmlTable -td = cell . thetd - -tda :: [HtmlAttr] -> Html -> HtmlTable -tda as = cell . (thetd ! as) - -above, beside :: HtmlTable -> HtmlTable -> HtmlTable -above a b = combine BT.above a b -beside a b = combine BT.beside a b - -infixr 3 </> -- combining table cells -infixr 4 <-> -- combining table cells -(</>), (<->) :: HtmlTable -> HtmlTable -> HtmlTable -(</>) = above -(<->) = beside - -emptyTable :: HtmlTable -emptyTable = HtmlTable BT.empty - -aboves, besides :: [HtmlTable] -> HtmlTable -aboves = foldr above emptyTable -besides = foldr beside emptyTable - -mkHtmlTable :: BT.BlockTable (Int -> Int -> Html) -> HtmlTable -mkHtmlTable r = HtmlTable r - -combine :: (BT.BlockTable (Int -> Int -> Html) - -> BT.BlockTable (Int -> Int -> Html) - -> BT.BlockTable (Int -> Int -> Html)) - -> HtmlTable -> HtmlTable -> HtmlTable -combine fn (HtmlTable a) (HtmlTable b) = mkHtmlTable (a `fn` b) - --- renderTable takes the HtmlTable, and renders it back into --- and Html object. - -renderTable :: BT.BlockTable (Int -> Int -> Html) -> Html -renderTable theTable - = concatHtml - [tr << [theCell x y | (theCell,(x,y)) <- theRow ] - | theRow <- BT.getMatrix theTable] - -instance HTML HtmlTable where - toHtml (HtmlTable tab) = renderTable tab - -instance Show HtmlTable where - showsPrec _ (HtmlTable tab) = shows (renderTable tab) - - --- If you can't be bothered with the above, then you --- can build simple tables with simpleTable. --- Just provide the attributes for the whole table, --- attributes for the cells (same for every cell), --- and a list of lists of cell contents, --- and this function will build the table for you. --- It does presume that all the lists are non-empty, --- and there is at least one list. --- --- Different length lists means that the last cell --- gets padded. If you want more power, then --- use the system above, or build tables explicitly. - -simpleTable :: HTML a => [HtmlAttr] -> [HtmlAttr] -> [[a]] -> Html -simpleTable attr cellAttr lst - = table ! attr - << (aboves - . map (besides . map (cell . (thetd ! cellAttr) . toHtml)) - ) lst - - --- --------------------------------------------------------------------------- --- Tree Displaying Combinators - --- The basic idea is you render your structure in the form --- of this tree, and then use treeHtml to turn it into a Html --- object with the structure explicit. - -data HtmlTree - = HtmlLeaf Html - | HtmlNode Html [HtmlTree] Html - -treeHtml :: [String] -> HtmlTree -> Html -treeHtml colors h = table ! [ - border 0, - cellpadding 0, - cellspacing 2] << treeHtml' colors h - where - manycolors = scanr (:) [] - - treeHtmls :: [[String]] -> [HtmlTree] -> HtmlTable - treeHtmls c ts = aboves (zipWith treeHtml' c ts) - - treeHtml' :: [String] -> HtmlTree -> HtmlTable - treeHtml' (_:_) (HtmlLeaf leaf) = cell - (thetd ! [width "100%"] - << bold - << leaf) - treeHtml' (c:cs@(c2:_)) (HtmlNode hopen ts hclose) = - if null ts && isNoHtml hclose - then - hd - else if null ts - then - hd </> bar `beside` (cell . (thetd ! [bgcolor c2]) << spaceHtml) - </> tl - else - hd </> (bar `beside` treeHtmls morecolors ts) - </> tl - where - -- This stops a column of colors being the same - -- color as the immeduately outside nesting bar. - morecolors = filter ((/= c).head) (manycolors cs) - bar = cell (thetd ! [bgcolor c,width "10"] << spaceHtml) - hd = cell (thetd ! [bgcolor c] << hopen) - tl = cell (thetd ! [bgcolor c] << hclose) - treeHtml' _ _ = error "The imposible happens" - -instance HTML HtmlTree where - toHtml x = treeHtml treeColors x - --- type "length treeColors" to see how many colors are here. -treeColors :: [String] -treeColors = ["#88ccff","#ffffaa","#ffaaff","#ccffff"] ++ treeColors - - --- --------------------------------------------------------------------------- --- Html Debugging Combinators - --- This uses the above tree rendering function, and displays the --- Html as a tree structure, allowing debugging of what is --- actually getting produced. - -debugHtml :: (HTML a) => a -> Html -debugHtml obj = table ! [border 0] << ( - cell (th ! [bgcolor "#008888"] - << underline - << "Debugging Output") - </> td << (toHtml (debug' (toHtml obj))) - ) - where - - debug' :: Html -> [HtmlTree] - debug' (Html markups) = map debug markups - - debug :: HtmlElement -> HtmlTree - debug (HtmlString str) = HtmlLeaf (spaceHtml +++ - linesToHtml (lines str)) - debug (HtmlTag { - markupTag = markupTag0, - markupContent = markupContent0, - markupAttrs = markupAttrs0 - }) = - case markupContent0 of - Html [] -> HtmlNode hd [] noHtml - Html xs -> HtmlNode hd (map debug xs) tl - where - args = if null markupAttrs0 - then "" - else " " ++ unwords (map show markupAttrs0) - hd = font ! [size "1"] << ("<" ++ markupTag0 ++ args ++ ">") - tl = font ! [size "1"] << ("</" ++ markupTag0 ++ ">") - --- --------------------------------------------------------------------------- --- Hotlink datatype - -data HotLink = HotLink { - hotLinkURL :: URL, - hotLinkContents :: [Html], - hotLinkAttributes :: [HtmlAttr] - } deriving Show - -instance HTML HotLink where - toHtml hl = anchor ! (href (hotLinkURL hl) : hotLinkAttributes hl) - << hotLinkContents hl - -hotlink :: URL -> [Html] -> HotLink -hotlink url h = HotLink { - hotLinkURL = url, - hotLinkContents = h, - hotLinkAttributes = [] } - - --- --------------------------------------------------------------------------- --- More Combinators - --- (Abridged from Erik Meijer's Original Html library) - -ordList :: (HTML a) => [a] -> Html -ordList items = olist << map (li <<) items - -unordList :: (HTML a) => [a] -> Html -unordList items = ulist << map (li <<) items - -defList :: (HTML a,HTML b) => [(a,b)] -> Html -defList items - = dlist << [ [ dterm << bold << dt, ddef << dd ] | (dt,dd) <- items ] - - -widget :: String -> String -> [HtmlAttr] -> Html -widget w n markupAttrs0 = input ! ([thetype w,name n] ++ markupAttrs0) - -checkbox :: String -> String -> Html -hidden :: String -> String -> Html -radio :: String -> String -> Html -reset :: String -> String -> Html -submit :: String -> String -> Html -password :: String -> Html -textfield :: String -> Html -afile :: String -> Html -clickmap :: String -> Html - -checkbox n v = widget "CHECKBOX" n [value v] -hidden n v = widget "HIDDEN" n [value v] -radio n v = widget "RADIO" n [value v] -reset n v = widget "RESET" n [value v] -submit n v = widget "SUBMIT" n [value v] -password n = widget "PASSWORD" n [] -textfield n = widget "TEXT" n [] -afile n = widget "FILE" n [] -clickmap n = widget "IMAGE" n [] - -menu :: String -> [Html] -> Html -menu n choices - = select ! [name n] << [ option << p << choice | choice <- choices ] - -gui :: String -> Html -> Html -gui act = form ! [action act,method "POST"] - --- --------------------------------------------------------------------------- --- Html Rendering - --- Uses the append trick to optimize appending. --- The output is quite messy, because space matters in --- HTML, so we must not generate needless spaces. - -renderHtml :: (HTML html) => html -> String -renderHtml theHtml = - renderMessage ++ - foldr (.) id (map unprettyHtml - (getHtmlElements (tag "HTML" << theHtml))) "\n" - -renderMessage :: String -renderMessage = - "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\" \"http://www.w3.org/TR/html4/loose.dtd\">\n" ++ - "<!--Rendered using the Haskell Html Library v0.2-->\n" - -unprettyHtml :: HtmlElement -> ShowS -unprettyHtml (HtmlString str) = (++) str -unprettyHtml (HtmlTag - { markupTag = name0, - markupContent = html, - markupAttrs = markupAttrs0 }) - = if isNoHtml html && elem name0 validHtmlITags - then renderTag True name0 markupAttrs0 0 - else (renderTag True name0 markupAttrs0 0 - . foldr (.) id (map unprettyHtml (getHtmlElements html)) - . renderTag False name0 [] 0) - --- Local Utilities -prettyHtml :: (HTML html) => html -> String -prettyHtml theHtml = - unlines - $ concat - $ map prettyHtml' - $ getHtmlElements - $ toHtml theHtml - -prettyHtml' :: HtmlElement -> [String] -prettyHtml' (HtmlString str) = [str] -prettyHtml' (HtmlTag - { markupTag = name0, - markupContent = html, - markupAttrs = markupAttrs0 }) - = if isNoHtml html && elem name0 validHtmlITags - then - [rmNL (renderTag True name0 markupAttrs0 0 "")] - else - [rmNL (renderTag True name0 markupAttrs0 0 "")] ++ - shift (concat (map prettyHtml' (getHtmlElements html))) ++ - [rmNL (renderTag False name0 [] 0 "")] - where - shift = map (\x -> " " ++ x) - -rmNL :: [Char] -> [Char] -rmNL = filter (/= '\n') - --- This prints the Tags The lack of spaces in intentunal, because Html is --- actually space dependant. - -renderTag :: Bool -> String -> [HtmlAttr] -> Int -> ShowS -renderTag x name0 markupAttrs0 n r - = open ++ name0 ++ rest markupAttrs0 ++ ">" ++ r - where - open = if x then "<" else "</" - - nl = "\n" ++ replicate (n `div` 8) '\t' - ++ replicate (n `mod` 8) ' ' - - rest [] = nl - rest attr = " " ++ unwords (map showPair attr) ++ nl - - showPair :: HtmlAttr -> String - showPair (HtmlAttr tag0 val) - = tag0 ++ "=\"" ++ val ++ "\"" - diff --git a/src/Main.hs b/src/Main.hs index b3613a51..f75dcad9 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -18,9 +18,8 @@ module Main (main) where -import qualified Haddock.Backends.Html as Html -import qualified Haddock.Backends.Xhtml as Xhtml -import qualified Haddock.Backends.LaTeX as LaTeX +import Haddock.Backends.Xhtml +import Haddock.Backends.LaTeX import Haddock.Backends.Hoogle import Haddock.Interface import Haddock.Lex @@ -195,14 +194,6 @@ render flags ifaces installedIfaces = do packageStr = Just (modulePackageString packageMod) (pkgName,pkgVer) = modulePackageInfo packageMod - -- Which HTML rendering to use. - pick htmlF xhtmlF = if Flag_Xhtml `elem` flags then xhtmlF else htmlF - ppHtmlIndex = pick Html.ppHtmlIndex Xhtml.ppHtmlIndex - ppHtmlHelpFiles = pick Html.ppHtmlHelpFiles Xhtml.ppHtmlHelpFiles - ppHtmlContents = pick Html.ppHtmlContents Xhtml.ppHtmlContents - ppHtml = pick Html.ppHtml Xhtml.ppHtml - copyHtmlBits = pick Html.copyHtmlBits Xhtml.copyHtmlBits - libDir <- getHaddockLibDir flags prologue <- getPrologue flags @@ -233,7 +224,7 @@ render flags ifaces installedIfaces = do ppHoogle pkgName2 pkgVer title prologue visibleIfaces odir when (Flag_LaTeX `elem` flags) $ do - LaTeX.ppLaTeX title packageStr visibleIfaces odir prologue opt_latex_style + ppLaTeX title packageStr visibleIfaces odir prologue opt_latex_style libDir ------------------------------------------------------------------------------- |