1----------------------------------------------------------------------------- 2-- | 3-- Module : Haddock.Backends.Html.Layout 4-- Copyright : (c) Simon Marlow 2003-2006, 5-- David Waern 2006-2009, 6-- Mark Lentczner 2010 7-- License : BSD-like 8-- 9-- Maintainer : haddock@projects.haskell.org 10-- Stability : experimental 11-- Portability : portable 12----------------------------------------------------------------------------- 13module Haddock.Backends.Xhtml.Layout ( 14 miniBody, 15 16 divPackageHeader, divContent, divModuleHeader, divFooter, 17 divTableOfContents, divDescription, divSynopsis, divInterface, 18 divIndex, divAlphabet, divModuleList, divContentsList, 19 20 sectionName, 21 nonEmptySectionName, 22 23 shortDeclList, 24 shortSubDecls, 25 26 divTopDecl, 27 28 SubDecl, 29 subArguments, 30 subAssociatedTypes, 31 subConstructors, 32 subPatterns, 33 subEquations, 34 subFields, 35 subInstances, subOrphanInstances, 36 subInstHead, subInstDetails, subFamInstDetails, 37 subMethods, 38 subDefaults, 39 subMinimal, 40 41 topDeclElem, declElem, 42) where 43 44import Haddock.Backends.Xhtml.DocMarkup 45import Haddock.Backends.Xhtml.Types 46import Haddock.Backends.Xhtml.Utils 47import Haddock.Types 48import Haddock.Utils (makeAnchorId, nameAnchorId) 49import qualified Data.Map as Map 50import Text.XHtml hiding ( name, title, quote ) 51import Data.Maybe (fromMaybe) 52 53import FastString ( unpackFS ) 54import GHC 55import Name (nameOccName) 56 57-------------------------------------------------------------------------------- 58-- * Sections of the document 59-------------------------------------------------------------------------------- 60 61 62miniBody :: Html -> Html 63miniBody = body ! [identifier "mini"] 64 65 66sectionDiv :: String -> Html -> Html 67sectionDiv i = thediv ! [identifier i] 68 69 70sectionName :: Html -> Html 71sectionName = paragraph ! [theclass "caption"] 72 73 74-- | Make an element that always has at least something (a non-breaking space). 75-- If it would have otherwise been empty, then give it the class ".empty". 76nonEmptySectionName :: Html -> Html 77nonEmptySectionName c 78 | isNoHtml c = thespan ! [theclass "caption empty"] $ spaceHtml 79 | otherwise = thespan ! [theclass "caption"] $ c 80 81 82divPackageHeader, divContent, divModuleHeader, divFooter, 83 divTableOfContents, divDescription, divSynopsis, divInterface, 84 divIndex, divAlphabet, divModuleList, divContentsList 85 :: Html -> Html 86 87divPackageHeader = sectionDiv "package-header" 88divContent = sectionDiv "content" 89divModuleHeader = sectionDiv "module-header" 90divFooter = sectionDiv "footer" 91divTableOfContents = sectionDiv "table-of-contents" 92divContentsList = sectionDiv "contents-list" 93divDescription = sectionDiv "description" 94divSynopsis = sectionDiv "synopsis" 95divInterface = sectionDiv "interface" 96divIndex = sectionDiv "index" 97divAlphabet = sectionDiv "alphabet" 98divModuleList = sectionDiv "module-list" 99 100 101-------------------------------------------------------------------------------- 102-- * Declaration containers 103-------------------------------------------------------------------------------- 104 105 106shortDeclList :: [Html] -> Html 107shortDeclList items = ulist << map (li ! [theclass "src short"] <<) items 108 109 110shortSubDecls :: Bool -> [Html] -> Html 111shortSubDecls inst items = ulist ! [theclass c] << map (i <<) items 112 where i | inst = li ! [theclass "inst"] 113 | otherwise = li 114 c | inst = "inst" 115 | otherwise = "subs" 116 117 118divTopDecl :: Html -> Html 119divTopDecl = thediv ! [theclass "top"] 120 121 122type SubDecl = (Html, Maybe (MDoc DocName), [Html]) 123 124 125divSubDecls :: (HTML a) => String -> a -> Maybe Html -> Html 126divSubDecls cssClass captionName = maybe noHtml wrap 127 where 128 wrap = (subSection <<) . (subCaption +++) 129 subSection = thediv ! [theclass $ unwords ["subs", cssClass]] 130 subCaption = paragraph ! [theclass "caption"] << captionName 131 132 133subDlist :: Maybe Package -> Qualification -> [SubDecl] -> Maybe Html 134subDlist _ _ [] = Nothing 135subDlist pkg qual decls = Just $ ulist << map subEntry decls 136 where 137 subEntry (decl, mdoc, subs) = 138 li << 139 (define ! [theclass "src"] << decl +++ 140 docElement thediv << (fmap (docToHtml Nothing pkg qual) mdoc +++ subs)) 141 142 143subTable :: Maybe Package -> Qualification -> [SubDecl] -> Maybe Html 144subTable _ _ [] = Nothing 145subTable pkg qual decls = Just $ table << aboves (concatMap subRow decls) 146 where 147 subRow (decl, mdoc, subs) = 148 (td ! [theclass "src"] << decl 149 <-> 150 docElement td << fmap (docToHtml Nothing pkg qual) mdoc) 151 : map (cell . (td <<)) subs 152 153 154-- | Sub table with source information (optional). 155subTableSrc :: Maybe Package -> Qualification -> LinksInfo -> Bool 156 -> [(SubDecl, Maybe Module, Located DocName)] -> Maybe Html 157subTableSrc _ _ _ _ [] = Nothing 158subTableSrc pkg qual lnks splice decls = Just $ table << aboves (concatMap subRow decls) 159 where 160 subRow ((decl, mdoc, subs), mdl, L loc dn) = 161 (td ! [theclass "src clearfix"] << 162 (thespan ! [theclass "inst-left"] << decl) 163 <+> linkHtml loc mdl dn 164 <-> 165 docElement td << fmap (docToHtml Nothing pkg qual) mdoc 166 ) 167 : map (cell . (td <<)) subs 168 169 linkHtml :: SrcSpan -> Maybe Module -> DocName -> Html 170 linkHtml loc@(RealSrcSpan _) mdl dn = links lnks loc splice mdl dn 171 linkHtml _ _ _ = noHtml 172 173subBlock :: [Html] -> Maybe Html 174subBlock [] = Nothing 175subBlock hs = Just $ toHtml hs 176 177 178subArguments :: Maybe Package -> Qualification -> [SubDecl] -> Html 179subArguments pkg qual = divSubDecls "arguments" "Arguments" . subTable pkg qual 180 181 182subAssociatedTypes :: [Html] -> Html 183subAssociatedTypes = divSubDecls "associated-types" "Associated Types" . subBlock 184 185 186subConstructors :: Maybe Package -> Qualification -> [SubDecl] -> Html 187subConstructors pkg qual = divSubDecls "constructors" "Constructors" . subTable pkg qual 188 189subPatterns :: Maybe Package -> Qualification -> [SubDecl] -> Html 190subPatterns pkg qual = divSubDecls "bundled-patterns" "Bundled Patterns" . subTable pkg qual 191 192subFields :: Maybe Package -> Qualification -> [SubDecl] -> Html 193subFields pkg qual = divSubDecls "fields" "Fields" . subDlist pkg qual 194 195 196subEquations :: Maybe Package -> Qualification -> [SubDecl] -> Html 197subEquations pkg qual = divSubDecls "equations" "Equations" . subTable pkg qual 198 199 200-- | Generate collapsible sub table for instance declarations, with source 201subInstances :: Maybe Package -> Qualification 202 -> String -- ^ Class name, used for anchor generation 203 -> LinksInfo -> Bool 204 -> [(SubDecl, Maybe Module, Located DocName)] -> Html 205subInstances pkg qual nm lnks splice = maybe noHtml wrap . instTable 206 where 207 wrap contents = subSection (hdr +++ collapseDetails id_ DetailsOpen (summary +++ contents)) 208 instTable = subTableSrc pkg qual lnks splice 209 subSection = thediv ! [theclass "subs instances"] 210 hdr = h4 ! collapseControl id_ "instances" << "Instances" 211 summary = thesummary ! [ theclass "hide-when-js-enabled" ] << "Instances details" 212 id_ = makeAnchorId $ "i:" ++ nm 213 214 215subOrphanInstances :: Maybe Package -> Qualification 216 -> LinksInfo -> Bool 217 -> [(SubDecl, Maybe Module, Located DocName)] -> Html 218subOrphanInstances pkg qual lnks splice = maybe noHtml wrap . instTable 219 where 220 wrap = ((h1 << "Orphan instances") +++) 221 instTable = fmap (thediv ! [ identifier ("section." ++ id_) ] <<) . subTableSrc pkg qual lnks splice 222 id_ = makeAnchorId $ "orphans" 223 224 225subInstHead :: String -- ^ Instance unique id (for anchor generation) 226 -> Html -- ^ Header content (instance name and type) 227 -> Html 228subInstHead iid hdr = 229 expander noHtml <+> hdr 230 where 231 expander = thespan ! collapseControl (instAnchorId iid) "instance" 232 233 234subInstDetails :: String -- ^ Instance unique id (for anchor generation) 235 -> [Html] -- ^ Associated type contents 236 -> [Html] -- ^ Method contents (pretty-printed signatures) 237 -> Html -- ^ Source module 238 -> Html 239subInstDetails iid ats mets mdl = 240 subInstSection iid << (p mdl <+> subAssociatedTypes ats <+> subMethods mets) 241 242subFamInstDetails :: String -- ^ Instance unique id (for anchor generation) 243 -> Html -- ^ Type or data family instance 244 -> Html -- ^ Source module TODO: use this 245 -> Html 246subFamInstDetails iid fi mdl = 247 subInstSection iid << (p mdl <+> (thediv ! [theclass "src"] << fi)) 248 249subInstSection :: String -- ^ Instance unique id (for anchor generation) 250 -> Html 251 -> Html 252subInstSection iid contents = collapseDetails (instAnchorId iid) DetailsClosed (summary +++ contents) 253 where 254 summary = thesummary ! [ theclass "hide-when-js-enabled" ] << "Instance details" 255 256instAnchorId :: String -> String 257instAnchorId iid = makeAnchorId $ "i:" ++ iid 258 259 260subMethods :: [Html] -> Html 261subMethods = divSubDecls "methods" "Methods" . subBlock 262 263subDefaults :: [Html] -> Html 264subDefaults = divSubDecls "default" "" . subBlock 265 266subMinimal :: Html -> Html 267subMinimal = divSubDecls "minimal" "Minimal complete definition" . Just . declElem 268 269 270-- a box for displaying code 271declElem :: Html -> Html 272declElem = paragraph ! [theclass "src"] 273 274 275-- a box for top level documented names 276-- it adds a source and wiki link at the right hand side of the box 277topDeclElem :: LinksInfo -> SrcSpan -> Bool -> [DocName] -> Html -> Html 278topDeclElem lnks loc splice names html = 279 declElem << (html <+> (links lnks loc splice Nothing $ head names)) 280 -- FIXME: is it ok to simply take the first name? 281 282-- | Adds a source and wiki link at the right hand side of the box. 283-- Name must be documented, otherwise we wouldn't get here. 284links :: LinksInfo -> SrcSpan -> Bool -> Maybe Module -> DocName -> Html 285links ((_,_,sourceMap,lineMap), (_,_,maybe_wiki_url)) loc splice mdl' docName@(Documented n mdl) = 286 srcLink <+> wikiLink <+> (selfLink ! [theclass "selflink"] << "#") 287 where selfLink = linkedAnchor (nameAnchorId (nameOccName (getName docName))) 288 289 srcLink = let nameUrl = Map.lookup origPkg sourceMap 290 lineUrl = Map.lookup origPkg lineMap 291 mUrl | splice = lineUrl 292 -- Use the lineUrl as a backup 293 | otherwise = maybe lineUrl Just nameUrl in 294 case mUrl of 295 Nothing -> noHtml 296 Just url -> let url' = spliceURL (Just fname) (Just origMod) 297 (Just n) (Just loc) url 298 in anchor ! [href url', theclass "link"] << "Source" 299 300 wikiLink = 301 case maybe_wiki_url of 302 Nothing -> noHtml 303 Just url -> let url' = spliceURL (Just fname) (Just mdl) 304 (Just n) (Just loc) url 305 in anchor ! [href url', theclass "link"] << "Comments" 306 307 -- For source links, we want to point to the original module, 308 -- because only that will have the source. 309 -- 310 -- 'mdl'' is a way of "overriding" the module. Without it, instances 311 -- will point to the module defining the class/family, which is wrong. 312 origMod = fromMaybe (nameModule n) mdl' 313 origPkg = moduleUnitId origMod 314 315 fname = case loc of 316 RealSrcSpan l -> unpackFS (srcSpanFile l) 317 UnhelpfulSpan _ -> error "links: UnhelpfulSpan" 318links _ _ _ _ _ = noHtml 319