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