aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Haddock/Backends/Xhtml.hs102
-rw-r--r--src/Haddock/Backends/Xhtml/Layout.hs2
-rw-r--r--src/Haddock/Backends/Xhtml/Util.hs6
3 files changed, 36 insertions, 74 deletions
diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs
index 8a66a987..31690b07 100644
--- a/src/Haddock/Backends/Xhtml.hs
+++ b/src/Haddock/Backends/Xhtml.hs
@@ -47,6 +47,7 @@ import System.IO ( IOMode(..), hClose, hGetBuf, hPutBuf, openFile )
import System.Directory hiding ( copyFile )
import Data.Map ( Map )
import qualified Data.Map as Map hiding ( Map )
+import Data.List ( intercalate )
import Data.Function
import Data.Ord ( comparing )
@@ -270,12 +271,11 @@ ppHtmlContents odir doctitle
styleSheet +++
(script ! [src jsFile, thetype "text/javascript"] $ noHtml)) +++
body << (
- simpleHeader doctitle Nothing maybe_index_url
- maybe_source_url maybe_wiki_url +++
- vanillaTable << (
- ppPrologue doctitle prologue </>
- ppModuleTree doctitle tree) +++
- footer
+ simpleHeader doctitle Nothing maybe_index_url
+ maybe_source_url maybe_wiki_url +++
+ ppPrologue doctitle prologue +++
+ ppModuleTree tree +++
+ footer
)
createDirectoryIfMissing True odir
writeFile (joinPath [odir, contentsHtmlFile]) (renderToString html)
@@ -291,75 +291,41 @@ ppHtmlContents odir doctitle
Just "devhelp" -> return ()
Just format -> fail ("The "++format++" format is not implemented")
-ppPrologue :: String -> Maybe (Doc GHC.RdrName) -> HtmlTable
-ppPrologue _ Nothing = emptyTable
-ppPrologue title (Just doc) =
- (tda [theclass "section1"] << toHtml title) </>
- (tda [theclass "doc"] << (rdrDocToHtml doc))
+ppPrologue :: String -> Maybe (Doc GHC.RdrName) -> Html
+ppPrologue _ Nothing = noHtml
+ppPrologue title (Just doc) =
+ divDescription << (h1 << title +++ 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_
+ppModuleTree :: [ModuleTree] -> Html
+ppModuleTree ts =
+ divModuleList << (sectionName << "Modules" +++ mkNodeList [] "n" ts)
- (htmlTable,_) = genTable emptyTable 0 ts
-
-mkNode :: [String] -> ModuleTree -> Int -> Int -> (HtmlTable,Int)
-mkNode ss (Node s leaf pkg short ts) depth id_ = htmlNode
+mkNodeList :: [String] -> String -> [ModuleTree] -> Html
+mkNodeList ss p ts = case ts of
+ [] -> noHtml
+ _ -> unordList (zipWith (mkNode ss) ps ts)
where
- htmlNode = case ts of
- [] -> (td_pad_w 1.25 depth << htmlModule <-> shortDescr <-> htmlPkg,id_)
- _ -> (td_w depth << (collapsebutton id_s +++ htmlModule) <-> shortDescr <-> htmlPkg </>
- (td_subtree << sub_tree), id')
-
- mod_width = 50::Int {-em-}
-
- td_pad_w :: Double -> Int -> Html -> HtmlTable
- td_pad_w pad depth_ =
- tda [thestyle ("padding-left: " ++ show pad ++ "em;" ++
- "width: " ++ show (mod_width - depth_*2) ++ "em")]
-
- td_w depth_ =
- tda [thestyle ("width: " ++ show (mod_width - depth_*2) ++ "em")]
-
- td_subtree =
- tda [thestyle ("padding: 0; padding-left: 2em")]
-
- shortDescr :: HtmlTable
- shortDescr = case short of
- Nothing -> cell $ td empty
- Just doc -> tda [theclass "rdoc"] (origDocToHtml doc)
-
+ ps = [ p ++ '.' : show i | i <- [(1::Int)..]]
+
+mkNode :: [String] -> String -> ModuleTree -> Html
+mkNode ss p (Node s leaf pkg short ts) =
+ collBtn +++ htmlModule +++ shortDescr +++ htmlPkg +++ subtree
+ where
+ collBtn = case ts of
+ [] -> noHtml
+ _ -> collapsebutton p
+
htmlModule
- | leaf = ppModule (mkModule (stringToPackageId pkgName)
+ | leaf = ppModule (mkModule (stringToPackageId (fromMaybe "" pkg))
(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_
+ mdl = intercalate "." (reverse (s:ss))
- (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__
+ shortDescr = maybe noHtml origDocToHtml short
+ htmlPkg = maybe noHtml toHtml pkg
+
+ subtree = mkNodeList (s:ss) p ts ! [identifier p]
-- | Turn a module tree into a flat list of full module names. E.g.,
@@ -392,7 +358,7 @@ ppHtmlContentsFrame odir doctitle ifaces = do
styleSheet +++
(script ! [src jsFile, thetype "text/javascript"] $ noHtml)) +++
miniBody << divModuleList <<
- (sectionName << "Modules" +++ shortDeclList mods)
+ (sectionName << "Modules" +++ unordList mods)
createDirectoryIfMissing True odir
writeFile (joinPath [odir, frameIndexHtmlFile]) (renderToString html)
diff --git a/src/Haddock/Backends/Xhtml/Layout.hs b/src/Haddock/Backends/Xhtml/Layout.hs
index b6818b61..616b3b95 100644
--- a/src/Haddock/Backends/Xhtml/Layout.hs
+++ b/src/Haddock/Backends/Xhtml/Layout.hs
@@ -135,7 +135,7 @@ subInstances :: String -> [SubDecl] -> Html
subInstances id_ = divSubDecls "instances" instCaption . instTable
where
instCaption = collapsebutton id_ +++ " Instances"
- instTable = (collapsed thediv id_ `fmap`) . subTable
+ instTable = fmap (thediv ! [identifier id_] <<) . subTable
subMethods :: [Html] -> Html
subMethods = divSubDecls "methods" "Methods" . subBlock
diff --git a/src/Haddock/Backends/Xhtml/Util.hs b/src/Haddock/Backends/Xhtml/Util.hs
index 13215bb7..d4ead8d8 100644
--- a/src/Haddock/Backends/Xhtml/Util.hs
+++ b/src/Haddock/Backends/Xhtml/Util.hs
@@ -25,7 +25,7 @@ module Haddock.Backends.Xhtml.Util (
tda, emptyTable, s8,
abovesSep, hsep,
- collapsebutton, collapseId, collapsed,
+ collapsebutton, collapseId,
documentCharacterEncoding,
cssFiles, styleSheet, stylePickers, styleMenu
@@ -206,10 +206,6 @@ 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
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-22 14:25:36 +0000