aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMark Lentczner <markl@glyphic.com>2010-07-22 06:22:23 +0000
committerMark Lentczner <markl@glyphic.com>2010-07-22 06:22:23 +0000
commit7e2afa2b0d80759066fd872bc6900c59534b0b46 (patch)
tree0e7be91d6e6211bdf2be0b552ca305784ae10a59
parent04cd27123ea28902e67cdc989f573056b9f70616 (diff)
remove old HTML backend
Diffstat
-rw-r--r--haddock.cabal6
-rw-r--r--src/Haddock/Backends/Html.hs2008
-rw-r--r--src/Haddock/Options.hs6
-rw-r--r--src/Haddock/Utils/BlockTable.hs180
-rw-r--r--src/Haddock/Utils/Html.hs1037
-rw-r--r--src/Main.hs15
-rw-r--r--tests/golden-tests/README2
-rw-r--r--tests/golden-tests/runtests.hs2
8 files changed, 7 insertions, 3249 deletions
diff --git a/haddock.cabal b/haddock.cabal
index 584bae9b..eaf3aadf 100644
--- a/haddock.cabal
+++ b/haddock.cabal
@@ -107,10 +107,7 @@ executable haddock
Haddock.Interface.ParseModuleHeader
Haddock.Lex
Haddock.Parse
- Haddock.Utils.BlockTable
- Haddock.Utils.Html
Haddock.Utils
- Haddock.Backends.Html
Haddock.Backends.Xhtml
Haddock.Backends.Xhtml.Decl
Haddock.Backends.Xhtml.DocMarkup
@@ -174,10 +171,7 @@ library
Haddock.Interface.ParseModuleHeader
Haddock.Lex
Haddock.Parse
- Haddock.Utils.BlockTable
- Haddock.Utils.Html
Haddock.Utils
- Haddock.Backends.Html
Haddock.Backends.Xhtml
Haddock.Backends.Xhtml.Decl
Haddock.Backends.Xhtml.DocMarkup
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 &gt;,etc.
-
-data HtmlElement
-{-
- - ..just..plain..normal..text... but using &copy; 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 '<' = "&lt;"
- fixChar '>' = "&gt;"
- fixChar '&' = "&amp;"
- fixChar '"' = "&quot;"
- 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 ' ' = "&nbsp;"
- 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
-------------------------------------------------------------------------------
diff --git a/tests/golden-tests/README b/tests/golden-tests/README
index f538cea7..fd906b2b 100644
--- a/tests/golden-tests/README
+++ b/tests/golden-tests/README
@@ -25,4 +25,4 @@ You can
to continue despite a failing test.
You can pass extra options to haddock like so
- runhaskell runtests.hs --xhtml all
+ runhaskell runtests.hs --title="All Tests" all
diff --git a/tests/golden-tests/runtests.hs b/tests/golden-tests/runtests.hs
index 20fb6eb4..7d5ec865 100644
--- a/tests/golden-tests/runtests.hs
+++ b/tests/golden-tests/runtests.hs
@@ -63,7 +63,7 @@ test = do
putStrLn "Running tests..."
handle <- runProcess haddockPath
- (["-w", "-o", outdir, "-h", "--xhtml", "--optghc=-fglasgow-exts"
+ (["-w", "-o", outdir, "-h", "--optghc=-fglasgow-exts"
, "--optghc=-w", base, process, ghcprim] ++ opts ++ mods')
Nothing (Just [("haddock_datadir", haddockBase)]) Nothing
Nothing Nothing
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-15 12:50:22 +0000