aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api/src/Haddock/Backends/Xhtml/Layout.hs')
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Layout.hs235
1 files changed, 235 insertions, 0 deletions
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
new file mode 100644
index 00000000..e84a57b3
--- /dev/null
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs
@@ -0,0 +1,235 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Haddock.Backends.Html.Layout
+-- Copyright : (c) Simon Marlow 2003-2006,
+-- David Waern 2006-2009,
+-- Mark Lentczner 2010
+-- License : BSD-like
+--
+-- Maintainer : haddock@projects.haskell.org
+-- Stability : experimental
+-- Portability : portable
+-----------------------------------------------------------------------------
+module Haddock.Backends.Xhtml.Layout (
+ miniBody,
+
+ divPackageHeader, divContent, divModuleHeader, divFooter,
+ divTableOfContents, divDescription, divSynposis, divInterface,
+ divIndex, divAlphabet, divModuleList,
+
+ sectionName,
+ nonEmptySectionName,
+
+ shortDeclList,
+ shortSubDecls,
+
+ divTopDecl,
+
+ SubDecl,
+ subArguments,
+ subAssociatedTypes,
+ subConstructors,
+ subEquations,
+ subFields,
+ subInstances,
+ subMethods,
+ subMinimal,
+
+ topDeclElem, declElem,
+) where
+
+
+import Haddock.Backends.Xhtml.DocMarkup
+import Haddock.Backends.Xhtml.Types
+import Haddock.Backends.Xhtml.Utils
+import Haddock.Types
+import Haddock.Utils (makeAnchorId)
+
+import qualified Data.Map as Map
+import Text.XHtml hiding ( name, title, p, quote )
+
+import FastString ( unpackFS )
+import GHC
+
+
+--------------------------------------------------------------------------------
+-- * Sections of the document
+--------------------------------------------------------------------------------
+
+
+miniBody :: Html -> Html
+miniBody = body ! [identifier "mini"]
+
+
+sectionDiv :: String -> Html -> Html
+sectionDiv i = thediv ! [identifier i]
+
+
+sectionName :: Html -> Html
+sectionName = paragraph ! [theclass "caption"]
+
+
+-- | Make an element that always has at least something (a non-breaking space).
+-- If it would have otherwise been empty, then give it the class ".empty".
+nonEmptySectionName :: Html -> Html
+nonEmptySectionName c
+ | isNoHtml c = paragraph ! [theclass "caption empty"] $ spaceHtml
+ | otherwise = paragraph ! [theclass "caption"] $ c
+
+
+divPackageHeader, divContent, divModuleHeader, divFooter,
+ divTableOfContents, divDescription, divSynposis, divInterface,
+ divIndex, divAlphabet, divModuleList
+ :: Html -> Html
+
+divPackageHeader = sectionDiv "package-header"
+divContent = sectionDiv "content"
+divModuleHeader = sectionDiv "module-header"
+divFooter = sectionDiv "footer"
+divTableOfContents = sectionDiv "table-of-contents"
+divDescription = sectionDiv "description"
+divSynposis = sectionDiv "synopsis"
+divInterface = sectionDiv "interface"
+divIndex = sectionDiv "index"
+divAlphabet = sectionDiv "alphabet"
+divModuleList = sectionDiv "module-list"
+
+
+--------------------------------------------------------------------------------
+-- * Declaration containers
+--------------------------------------------------------------------------------
+
+
+shortDeclList :: [Html] -> Html
+shortDeclList items = ulist << map (li ! [theclass "src short"] <<) items
+
+
+shortSubDecls :: Bool -> [Html] -> Html
+shortSubDecls inst items = ulist ! [theclass c] << map (i <<) items
+ where i | inst = li ! [theclass "inst"]
+ | otherwise = li
+ c | inst = "inst"
+ | otherwise = "subs"
+
+
+divTopDecl :: Html -> Html
+divTopDecl = thediv ! [theclass "top"]
+
+
+type SubDecl = (Html, Maybe (Doc DocName), [Html])
+
+
+divSubDecls :: (HTML a) => String -> a -> Maybe Html -> Html
+divSubDecls cssClass captionName = maybe noHtml wrap
+ where
+ wrap = (subSection <<) . (subCaption +++)
+ subSection = thediv ! [theclass $ unwords ["subs", cssClass]]
+ subCaption = paragraph ! [theclass "caption"] << captionName
+
+
+subDlist :: Qualification -> [SubDecl] -> Maybe Html
+subDlist _ [] = Nothing
+subDlist qual decls = Just $ dlist << map subEntry decls +++ clearDiv
+ where
+ subEntry (decl, mdoc, subs) =
+ dterm ! [theclass "src"] << decl
+ +++
+ docElement ddef << (fmap (docToHtml qual) mdoc +++ subs)
+
+ clearDiv = thediv ! [ theclass "clear" ] << noHtml
+
+
+subTable :: Qualification -> [SubDecl] -> Maybe Html
+subTable _ [] = Nothing
+subTable qual decls = Just $ table << aboves (concatMap subRow decls)
+ where
+ subRow (decl, mdoc, subs) =
+ (td ! [theclass "src"] << decl
+ <->
+ docElement td << fmap (docToHtml qual) mdoc)
+ : map (cell . (td <<)) subs
+
+
+subBlock :: [Html] -> Maybe Html
+subBlock [] = Nothing
+subBlock hs = Just $ toHtml hs
+
+
+subArguments :: Qualification -> [SubDecl] -> Html
+subArguments qual = divSubDecls "arguments" "Arguments" . subTable qual
+
+
+subAssociatedTypes :: [Html] -> Html
+subAssociatedTypes = divSubDecls "associated-types" "Associated Types" . subBlock
+
+
+subConstructors :: Qualification -> [SubDecl] -> Html
+subConstructors qual = divSubDecls "constructors" "Constructors" . subTable qual
+
+
+subFields :: Qualification -> [SubDecl] -> Html
+subFields qual = divSubDecls "fields" "Fields" . subDlist qual
+
+
+subEquations :: Qualification -> [SubDecl] -> Html
+subEquations qual = divSubDecls "equations" "Equations" . subTable qual
+
+
+subInstances :: Qualification -> String -> [SubDecl] -> Html
+subInstances qual nm = maybe noHtml wrap . instTable
+ where
+ wrap = (subSection <<) . (subCaption +++)
+ instTable = fmap (thediv ! collapseSection id_ True [] <<) . subTable qual
+ subSection = thediv ! [theclass "subs instances"]
+ subCaption = paragraph ! collapseControl id_ True "caption" << "Instances"
+ id_ = makeAnchorId $ "i:" ++ nm
+
+subMethods :: [Html] -> Html
+subMethods = divSubDecls "methods" "Methods" . subBlock
+
+subMinimal :: Html -> Html
+subMinimal = divSubDecls "minimal" "Minimal complete definition" . Just . declElem
+
+
+-- a box for displaying code
+declElem :: Html -> Html
+declElem = paragraph ! [theclass "src"]
+
+
+-- a box for top level documented names
+-- it adds a source and wiki link at the right hand side of the box
+topDeclElem :: LinksInfo -> SrcSpan -> Bool -> [DocName] -> Html -> Html
+topDeclElem ((_,_,sourceMap,lineMap), (_,_,maybe_wiki_url)) loc splice names html =
+ declElem << (html <+> srcLink <+> wikiLink)
+ where srcLink = let nameUrl = Map.lookup origPkg sourceMap
+ lineUrl = Map.lookup origPkg lineMap
+ mUrl | splice = lineUrl
+ -- Use the lineUrl as a backup
+ | otherwise = maybe lineUrl Just nameUrl in
+ case mUrl of
+ Nothing -> noHtml
+ Just url -> let url' = spliceURL (Just fname) (Just origMod)
+ (Just n) (Just loc) url
+ in anchor ! [href url', theclass "link"] << "Source"
+
+ wikiLink =
+ case maybe_wiki_url of
+ Nothing -> noHtml
+ Just url -> let url' = spliceURL (Just fname) (Just mdl)
+ (Just n) (Just loc) url
+ in anchor ! [href url', theclass "link"] << "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
+ origPkg = modulePackageId origMod
+
+ -- Name must be documented, otherwise we wouldn't get here
+ Documented n mdl = head names
+ -- FIXME: is it ok to simply take the first name?
+
+ fname = case loc of
+ RealSrcSpan l -> unpackFS (srcSpanFile l)
+ UnhelpfulSpan _ -> error "topDeclElem UnhelpfulSpan"
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 00:06:10 +0000