From efcaa44c353503aa7384de55091be70ac5fbb4ed Mon Sep 17 00:00:00 2001 From: Mark Lentczner Date: Fri, 16 Jul 2010 22:41:53 +0000 Subject: convert index to new markup --- src/Haddock/Backends/Xhtml.hs | 102 ++++++++++++----------------------- src/Haddock/Backends/Xhtml/Layout.hs | 2 +- src/Haddock/Backends/Xhtml/Util.hs | 6 +-- 3 files changed, 36 insertions(+), 74 deletions(-) (limited to 'src') 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 -- cgit v1.2.3