← Back to branch summary

~ubuntu-branches/ubuntu/precise/ghc/precise

« back to all changes in this revision

Viewing changes to utils/haddock/src/Haddock/Backends/Xhtml.hs

  • Committer: Bazaar Package Importer
  • Author(s): Joachim Breitner
  • Date: 2011-01-17 12:49:24 UTC
  • Revision ID: james.westby@ubuntu.com-20110117124924-do1pym1jlf5o636m
Tags: upstream-7.0.1
Import upstream version 7.0.1

Show diffs side-by-side

added added

removed removed

Lines of Context:
utils/haddock/src/Haddock/Backends/Xhtml.hs
 
1
-----------------------------------------------------------------------------
 
2
-- |
 
3
-- Module      :  Haddock.Backends.Html
 
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
-----------------------------------------------------------------------------
 
13
module Haddock.Backends.Xhtml (
 
14
  ppHtml, copyHtmlBits,
 
15
  ppHtmlIndex, ppHtmlContents,
 
16
) where
 
17
 
 
18
 
 
19
import Prelude hiding (div)
 
20
 
 
21
import Haddock.Backends.Xhtml.Decl
 
22
import Haddock.Backends.Xhtml.DocMarkup
 
23
import Haddock.Backends.Xhtml.Layout
 
24
import Haddock.Backends.Xhtml.Names
 
25
import Haddock.Backends.Xhtml.Themes
 
26
import Haddock.Backends.Xhtml.Types
 
27
import Haddock.Backends.Xhtml.Utils
 
28
import Haddock.ModuleTree
 
29
import Haddock.Types
 
30
import Haddock.Version
 
31
import Haddock.Utils
 
32
import Text.XHtml hiding ( name, title, p, quote )
 
33
import Haddock.GhcUtils
 
34
 
 
35
import Control.Monad         ( when, unless )
 
36
import Control.Monad.Instances ( ) -- for Functor Either a
 
37
import Data.Char             ( toUpper )
 
38
import Data.List             ( sortBy, groupBy )
 
39
import Data.Maybe
 
40
import System.FilePath hiding ( (</>) )
 
41
import System.Directory
 
42
import Data.Map              ( Map )
 
43
import qualified Data.Map as Map hiding ( Map )
 
44
import Data.List             ( intercalate )
 
45
import Data.Function
 
46
import Data.Ord              ( comparing )
 
47
 
 
48
import GHC hiding ( NoLink, moduleInfo )
 
49
import Name
 
50
import Module
 
51
 
 
52
 
 
53
--------------------------------------------------------------------------------
 
54
-- * Generating HTML documentation
 
55
--------------------------------------------------------------------------------
 
56
 
 
57
 
 
58
ppHtml :: String
 
59
       -> Maybe String                 -- package
 
60
       -> [Interface]
 
61
       -> FilePath                     -- destination directory
 
62
       -> Maybe (Doc GHC.RdrName)      -- prologue text, maybe
 
63
       -> Themes                       -- themes
 
64
       -> SourceURLs                   -- the source URL (--source)
 
65
       -> WikiURLs                     -- the wiki URL (--wiki)
 
66
       -> Maybe String                 -- the contents URL (--use-contents)
 
67
       -> Maybe String                 -- the index URL (--use-index)
 
68
       -> Bool                         -- whether to use unicode in output (--use-unicode)
 
69
       -> IO ()
 
70
 
 
71
ppHtml doctitle maybe_package ifaces odir prologue
 
72
        themes maybe_source_url maybe_wiki_url
 
73
        maybe_contents_url maybe_index_url unicode =  do
 
74
  let
 
75
        visible_ifaces = filter visible ifaces
 
76
        visible i = OptHide `notElem` ifaceOptions i
 
77
  when (not (isJust maybe_contents_url)) $
 
78
    ppHtmlContents odir doctitle maybe_package
 
79
        themes maybe_index_url maybe_source_url maybe_wiki_url
 
80
        (map toInstalledIface visible_ifaces)
 
81
        False -- we don't want to display the packages in a single-package contents
 
82
        prologue
 
83
 
 
84
  when (not (isJust maybe_index_url)) $
 
85
    ppHtmlIndex odir doctitle maybe_package
 
86
      themes maybe_contents_url maybe_source_url maybe_wiki_url
 
87
      (map toInstalledIface visible_ifaces)
 
88
 
 
89
  mapM_ (ppHtmlModule odir doctitle themes
 
90
           maybe_source_url maybe_wiki_url
 
91
           maybe_contents_url maybe_index_url unicode) visible_ifaces
 
92
 
 
93
 
 
94
copyHtmlBits :: FilePath -> FilePath -> Themes -> IO ()
 
95
copyHtmlBits odir libdir themes = do
 
96
  let
 
97
        libhtmldir = joinPath [libdir, "html"]
 
98
        copyCssFile f = do
 
99
           copyFile f (combine odir (takeFileName f))
 
100
        copyLibFile f = do
 
101
           copyFile (joinPath [libhtmldir, f]) (joinPath [odir, f])
 
102
  mapM_ copyCssFile (cssFiles themes)
 
103
  mapM_ copyLibFile [ jsFile, framesFile ]
 
104
 
 
105
 
 
106
headHtml :: String -> Maybe String -> Themes -> Html
 
107
headHtml docTitle miniPage themes =
 
108
  header << [
 
109
    meta ! [httpequiv "Content-Type", content "text/html; charset=UTF-8"],
 
110
    thetitle << docTitle,
 
111
    styleSheet themes,
 
112
    script ! [src jsFile, thetype "text/javascript"] << noHtml,
 
113
    script ! [thetype "text/javascript"]
 
114
        -- NB: Within XHTML, the content of script tags needs to be
 
115
        -- a <![CDATA[ section. Will break if the miniPage name could
 
116
        -- have "]]>" in it!
 
117
      << primHtml (
 
118
          "//<![CDATA[\nwindow.onload = function () {pageLoad();"
 
119
          ++ setSynopsis ++ "};\n//]]>\n")
 
120
    ]
 
121
  where
 
122
    setSynopsis = maybe "" (\p -> "setSynopsis(\"" ++ p ++ "\");") miniPage
 
123
 
 
124
 
 
125
srcButton :: SourceURLs -> Maybe Interface -> Maybe Html
 
126
srcButton (Just src_base_url, _, _) Nothing =
 
127
  Just (anchor ! [href src_base_url] << "Source")
 
128
srcButton (_, Just src_module_url, _) (Just iface) =
 
129
  let url = spliceURL (Just $ ifaceOrigFilename iface)
 
130
                      (Just $ ifaceMod iface) Nothing Nothing src_module_url
 
131
   in Just (anchor ! [href url] << "Source")
 
132
srcButton _ _ =
 
133
  Nothing
 
134
 
 
135
 
 
136
wikiButton :: WikiURLs -> Maybe Module -> Maybe Html
 
137
wikiButton (Just wiki_base_url, _, _) Nothing =
 
138
  Just (anchor ! [href wiki_base_url] << "User Comments")
 
139
 
 
140
wikiButton (_, Just wiki_module_url, _) (Just mdl) =
 
141
  let url = spliceURL Nothing (Just mdl) Nothing Nothing wiki_module_url
 
142
   in Just (anchor ! [href url] << "User Comments")
 
143
 
 
144
wikiButton _ _ =
 
145
  Nothing
 
146
 
 
147
 
 
148
contentsButton :: Maybe String -> Maybe Html
 
149
contentsButton maybe_contents_url
 
150
  = Just (anchor ! [href url] << "Contents")
 
151
  where url = maybe contentsHtmlFile id maybe_contents_url
 
152
 
 
153
 
 
154
indexButton :: Maybe String -> Maybe Html
 
155
indexButton maybe_index_url
 
156
  = Just (anchor ! [href url] << "Index")
 
157
  where url = maybe indexHtmlFile id maybe_index_url
 
158
 
 
159
 
 
160
bodyHtml :: String -> Maybe Interface
 
161
    -> SourceURLs -> WikiURLs
 
162
    -> Maybe String -> Maybe String
 
163
    -> Html -> Html
 
164
bodyHtml doctitle iface
 
165
           maybe_source_url maybe_wiki_url
 
166
           maybe_contents_url maybe_index_url
 
167
           pageContent =
 
168
  body << [
 
169
    divPackageHeader << [
 
170
      unordList (catMaybes [
 
171
        srcButton maybe_source_url iface,
 
172
        wikiButton maybe_wiki_url (ifaceMod `fmap` iface),
 
173
        contentsButton maybe_contents_url,
 
174
        indexButton maybe_index_url])
 
175
            ! [theclass "links", identifier "page-menu"],
 
176
      nonEmpty sectionName << doctitle
 
177
      ],
 
178
    divContent << pageContent,
 
179
    divFooter << paragraph << (
 
180
      "Produced by " +++
 
181
      (anchor ! [href projectUrl] << toHtml projectName) +++
 
182
      (" version " ++ projectVersion)
 
183
      )
 
184
    ]
 
185
 
 
186
 
 
187
moduleInfo :: Interface -> Html
 
188
moduleInfo iface =
 
189
   let
 
190
      info = ifaceInfo iface
 
191
 
 
192
      doOneEntry :: (String, (HaddockModInfo GHC.Name) -> Maybe String) -> Maybe HtmlTable
 
193
      doOneEntry (fieldName, field) =
 
194
        field info >>= \a -> return (th << fieldName <-> td << a)
 
195
 
 
196
      entries :: [HtmlTable]
 
197
      entries = mapMaybe doOneEntry [
 
198
         ("Portability",hmi_portability),
 
199
         ("Stability",hmi_stability),
 
200
         ("Maintainer",hmi_maintainer)
 
201
         ]
 
202
   in
 
203
      case entries of
 
204
         [] -> noHtml
 
205
         _ -> table ! [theclass "info"] << aboves entries
 
206
 
 
207
 
 
208
--------------------------------------------------------------------------------
 
209
-- * Generate the module contents
 
210
--------------------------------------------------------------------------------
 
211
 
 
212
 
 
213
ppHtmlContents
 
214
   :: FilePath
 
215
   -> String
 
216
   -> Maybe String
 
217
   -> Themes
 
218
   -> Maybe String
 
219
   -> SourceURLs
 
220
   -> WikiURLs
 
221
   -> [InstalledInterface] -> Bool -> Maybe (Doc GHC.RdrName)
 
222
   -> IO ()
 
223
ppHtmlContents odir doctitle _maybe_package
 
224
  themes maybe_index_url
 
225
  maybe_source_url maybe_wiki_url ifaces showPkgs prologue = do
 
226
  let tree = mkModuleTree showPkgs
 
227
         [(instMod iface, toInstalledDescription iface) | iface <- ifaces]
 
228
      html =
 
229
        headHtml doctitle Nothing themes +++
 
230
        bodyHtml doctitle Nothing
 
231
          maybe_source_url maybe_wiki_url
 
232
          Nothing maybe_index_url << [
 
233
            ppPrologue doctitle prologue,
 
234
            ppModuleTree tree
 
235
          ]
 
236
  createDirectoryIfMissing True odir
 
237
  writeFile (joinPath [odir, contentsHtmlFile]) (renderToString html)
 
238
 
 
239
  -- XXX: think of a better place for this?
 
240
  ppHtmlContentsFrame odir doctitle themes ifaces
 
241
 
 
242
 
 
243
ppPrologue :: String -> Maybe (Doc GHC.RdrName) -> Html
 
244
ppPrologue _ Nothing = noHtml
 
245
ppPrologue title (Just doc) =
 
246
  docElement divDescription << (h1 << title +++ rdrDocToHtml doc)
 
247
 
 
248
 
 
249
ppModuleTree :: [ModuleTree] -> Html
 
250
ppModuleTree ts =
 
251
  divModuleList << (sectionName << "Modules" +++ mkNodeList [] "n" ts)
 
252
 
 
253
 
 
254
mkNodeList :: [String] -> String -> [ModuleTree] -> Html
 
255
mkNodeList ss p ts = case ts of
 
256
  [] -> noHtml
 
257
  _ -> unordList (zipWith (mkNode ss) ps ts)
 
258
  where
 
259
    ps = [ p ++ '.' : show i | i <- [(1::Int)..]]
 
260
 
 
261
 
 
262
mkNode :: [String] -> String -> ModuleTree -> Html
 
263
mkNode ss p (Node s leaf pkg short ts) =
 
264
  htmlModule +++ shortDescr +++ htmlPkg +++ subtree
 
265
  where
 
266
    modAttrs = case (ts, leaf) of
 
267
      (_:_, False) -> collapseControl p True "module"
 
268
      (_,   _    ) -> [theclass "module"]
 
269
 
 
270
    cBtn = case (ts, leaf) of
 
271
      (_:_, True) -> thespan ! collapseControl p True "" << spaceHtml
 
272
      (_,   _   ) -> noHtml
 
273
      -- We only need an explicit collapser button when the module name
 
274
      -- is also a leaf, and so is a link to a module page. Indeed, the
 
275
      -- spaceHtml is a minor hack and does upset the layout a fraction.
 
276
      
 
277
    htmlModule = thespan ! modAttrs << (cBtn +++
 
278
      if leaf
 
279
        then ppModule (mkModule (stringToPackageId (fromMaybe "" pkg))
 
280
                                       (mkModuleName mdl))
 
281
        else toHtml s
 
282
      )
 
283
 
 
284
    mdl = intercalate "." (reverse (s:ss))
 
285
 
 
286
    shortDescr = maybe noHtml origDocToHtml short
 
287
    htmlPkg = maybe noHtml (thespan ! [theclass "package"] <<) pkg
 
288
 
 
289
    subtree = mkNodeList (s:ss) p ts ! collapseSection p True ""
 
290
 
 
291
 
 
292
-- | Turn a module tree into a flat list of full module names.  E.g.,
 
293
-- @
 
294
--  A
 
295
--  +-B
 
296
--  +-C
 
297
-- @
 
298
-- becomes
 
299
-- @["A", "A.B", "A.B.C"]@
 
300
flatModuleTree :: [InstalledInterface] -> [Html]
 
301
flatModuleTree ifaces =
 
302
    map (uncurry ppModule' . head)
 
303
            . groupBy ((==) `on` fst)
 
304
            . sortBy (comparing fst)
 
305
            $ mods
 
306
  where
 
307
    mods = [ (moduleString mdl, mdl) | mdl <- map instMod ifaces ]
 
308
    ppModule' txt mdl =
 
309
      anchor ! [href ((moduleHtmlFile mdl)), target mainFrameName]
 
310
        << toHtml txt
 
311
 
 
312
 
 
313
ppHtmlContentsFrame :: FilePath -> String -> Themes
 
314
  -> [InstalledInterface] -> IO ()
 
315
ppHtmlContentsFrame odir doctitle themes ifaces = do
 
316
  let mods = flatModuleTree ifaces
 
317
      html =
 
318
        headHtml doctitle Nothing themes +++
 
319
        miniBody << divModuleList <<
 
320
          (sectionName << "Modules" +++
 
321
           ulist << [ li ! [theclass "module"] << m | m <- mods ])
 
322
  createDirectoryIfMissing True odir
 
323
  writeFile (joinPath [odir, frameIndexHtmlFile]) (renderToString html)
 
324
 
 
325
 
 
326
--------------------------------------------------------------------------------
 
327
-- * Generate the index
 
328
--------------------------------------------------------------------------------
 
329
 
 
330
 
 
331
ppHtmlIndex :: FilePath
 
332
            -> String
 
333
            -> Maybe String
 
334
            -> Themes
 
335
            -> Maybe String
 
336
            -> SourceURLs
 
337
            -> WikiURLs
 
338
            -> [InstalledInterface]
 
339
            -> IO ()
 
340
ppHtmlIndex odir doctitle _maybe_package themes
 
341
  maybe_contents_url maybe_source_url maybe_wiki_url ifaces = do
 
342
  let html = indexPage split_indices Nothing
 
343
              (if split_indices then [] else index)
 
344
 
 
345
  createDirectoryIfMissing True odir
 
346
 
 
347
  when split_indices $
 
348
    mapM_ (do_sub_index index) initialChars
 
349
 
 
350
  writeFile (joinPath [odir, indexHtmlFile]) (renderToString html)
 
351
 
 
352
  where
 
353
    indexPage showLetters ch items =
 
354
      headHtml (doctitle ++ " (" ++ indexName ch ++ ")") Nothing themes +++
 
355
      bodyHtml doctitle Nothing
 
356
        maybe_source_url maybe_wiki_url
 
357
        maybe_contents_url Nothing << [
 
358
          if showLetters then indexInitialLetterLinks else noHtml,
 
359
          if null items then noHtml else
 
360
            divIndex << [sectionName << indexName ch, buildIndex items]
 
361
          ]
 
362
 
 
363
    indexName ch = "Index" ++ maybe "" (\c -> " - " ++ [c]) ch
 
364
 
 
365
    buildIndex items = table << aboves (map indexElt items)
 
366
 
 
367
    -- an arbitrary heuristic:
 
368
    -- too large, and a single-page will be slow to load
 
369
    -- too small, and we'll have lots of letter-indexes with only one
 
370
    --   or two members in them, which seems inefficient or
 
371
    --   unnecessarily hard to use.
 
372
    split_indices = length index > 150
 
373
 
 
374
    indexInitialLetterLinks =
 
375
      divAlphabet <<
 
376
          unordList [ anchor ! [href (subIndexHtmlFile c)] << [c]
 
377
                      | c <- initialChars
 
378
                      , any ((==c) . toUpper . head . fst) index ]
 
379
 
 
380
    -- todo: what about names/operators that start with Unicode
 
381
    -- characters?
 
382
    -- Exports beginning with '_' can be listed near the end,
 
383
    -- presumably they're not as important... but would be listed
 
384
    -- with non-split index!
 
385
    initialChars = [ 'A'..'Z' ] ++ ":!#$%&*+./<=>?@\\^|-~" ++ "_"
 
386
 
 
387
    do_sub_index this_ix c
 
388
      = unless (null index_part) $
 
389
          writeFile (joinPath [odir, subIndexHtmlFile c]) (renderToString html)
 
390
      where
 
391
        html = indexPage True (Just c) index_part
 
392
        index_part = [(n,stuff) | (n,stuff) <- this_ix, toUpper (head n) == c]
 
393
 
 
394
 
 
395
    index :: [(String, Map GHC.Name [(Module,Bool)])]
 
396
    index = sortBy cmp (Map.toAscList full_index)
 
397
      where cmp (n1,_) (n2,_) = map toUpper n1 `compare` map toUpper n2
 
398
 
 
399
    -- for each name (a plain string), we have a number of original HsNames that
 
400
    -- it can refer to, and for each of those we have a list of modules
 
401
    -- that export that entity.  Each of the modules exports the entity
 
402
    -- in a visible or invisible way (hence the Bool).
 
403
    full_index :: Map String (Map GHC.Name [(Module,Bool)])
 
404
    full_index = Map.fromListWith (flip (Map.unionWith (++)))
 
405
                 (concat (map getIfaceIndex ifaces))
 
406
 
 
407
    getIfaceIndex iface =
 
408
      [ (getOccString name
 
409
         , Map.fromList [(name, [(mdl, name `elem` instVisibleExports iface)])])
 
410
         | name <- instExports iface ]
 
411
      where mdl = instMod iface
 
412
 
 
413
    indexElt :: (String, Map GHC.Name [(Module,Bool)]) -> HtmlTable
 
414
    indexElt (str, entities) =
 
415
       case Map.toAscList entities of
 
416
          [(nm,entries)] ->
 
417
              td ! [ theclass "src" ] << toHtml str <->
 
418
                          indexLinks nm entries
 
419
          many_entities ->
 
420
              td ! [ theclass "src" ] << toHtml str <-> td << spaceHtml </>
 
421
                  aboves (map doAnnotatedEntity (zip [1..] many_entities))
 
422
 
 
423
    doAnnotatedEntity :: (Integer, (Name, [(Module, Bool)])) -> HtmlTable
 
424
    doAnnotatedEntity (j,(nm,entries))
 
425
          = td ! [ theclass "alt" ] <<
 
426
                  toHtml (show j) <+> parens (ppAnnot (nameOccName nm)) <->
 
427
                   indexLinks nm entries
 
428
 
 
429
    ppAnnot n | not (isValOcc n) = toHtml "Type/Class"
 
430
              | isDataOcc n      = toHtml "Data Constructor"
 
431
              | otherwise        = toHtml "Function"
 
432
 
 
433
    indexLinks nm entries =
 
434
       td ! [ theclass "module" ] <<
 
435
          hsep (punctuate comma
 
436
          [ if visible then
 
437
               linkId mdl (Just nm) << toHtml (moduleString mdl)
 
438
            else
 
439
               toHtml (moduleString mdl)
 
440
          | (mdl, visible) <- entries ])
 
441
 
 
442
 
 
443
--------------------------------------------------------------------------------
 
444
-- * Generate the HTML page for a module
 
445
--------------------------------------------------------------------------------
 
446
 
 
447
 
 
448
ppHtmlModule
 
449
        :: FilePath -> String -> Themes
 
450
        -> SourceURLs -> WikiURLs
 
451
        -> Maybe String -> Maybe String -> Bool
 
452
        -> Interface -> IO ()
 
453
ppHtmlModule odir doctitle themes
 
454
  maybe_source_url maybe_wiki_url
 
455
  maybe_contents_url maybe_index_url unicode iface = do
 
456
  let
 
457
      mdl = ifaceMod iface
 
458
      mdl_str = moduleString mdl
 
459
      html =
 
460
        headHtml mdl_str (Just $ "mini_" ++ moduleHtmlFile mdl) themes +++
 
461
        bodyHtml doctitle (Just iface)
 
462
          maybe_source_url maybe_wiki_url
 
463
          maybe_contents_url maybe_index_url << [
 
464
            divModuleHeader << (moduleInfo iface +++ (sectionName << mdl_str)),
 
465
            ifaceToHtml maybe_source_url maybe_wiki_url iface unicode
 
466
          ]
 
467
 
 
468
  createDirectoryIfMissing True odir
 
469
  writeFile (joinPath [odir, moduleHtmlFile mdl]) (renderToString html)
 
470
  ppHtmlModuleMiniSynopsis odir doctitle themes iface unicode
 
471
 
 
472
 
 
473
ppHtmlModuleMiniSynopsis :: FilePath -> String -> Themes
 
474
  -> Interface -> Bool -> IO ()
 
475
ppHtmlModuleMiniSynopsis odir _doctitle themes iface unicode = do
 
476
  let mdl = ifaceMod iface
 
477
      html =
 
478
        headHtml (moduleString mdl) Nothing themes +++
 
479
        miniBody <<
 
480
          (divModuleHeader << sectionName << moduleString mdl +++
 
481
           miniSynopsis mdl iface unicode)
 
482
  createDirectoryIfMissing True odir
 
483
  writeFile (joinPath [odir, "mini_" ++ moduleHtmlFile mdl]) (renderToString html)
 
484
 
 
485
 
 
486
ifaceToHtml :: SourceURLs -> WikiURLs -> Interface -> Bool -> Html
 
487
ifaceToHtml maybe_source_url maybe_wiki_url iface unicode
 
488
  = ppModuleContents exports +++
 
489
    description +++
 
490
    synopsis +++
 
491
    divInterface (maybe_doc_hdr +++ bdy)
 
492
  where
 
493
    exports = numberSectionHeadings (ifaceRnExportItems iface)
 
494
 
 
495
    -- todo: if something has only sub-docs, or fn-args-docs, should
 
496
    -- it be measured here and thus prevent omitting the synopsis?
 
497
    has_doc (ExportDecl _ doc _ _) = isJust (fst doc)
 
498
    has_doc (ExportNoDecl _ _) = False
 
499
    has_doc (ExportModule _) = False
 
500
    has_doc _ = True
 
501
 
 
502
    no_doc_at_all = not (any has_doc exports)
 
503
 
 
504
    description
 
505
          = case ifaceRnDoc iface of
 
506
              Nothing -> noHtml
 
507
              Just doc -> divDescription $
 
508
                            sectionName << "Description" +++ docSection doc
 
509
 
 
510
        -- omit the synopsis if there are no documentation annotations at all
 
511
    synopsis
 
512
      | no_doc_at_all = noHtml
 
513
      | otherwise
 
514
      = divSynposis $
 
515
            paragraph ! collapseControl "syn" False "caption" << "Synopsis" +++ 
 
516
            shortDeclList (
 
517
                mapMaybe (processExport True linksInfo unicode) exports
 
518
            ) ! (collapseSection "syn" False "" ++ collapseToggle "syn")
 
519
 
 
520
        -- if the documentation doesn't begin with a section header, then
 
521
        -- add one ("Documentation").
 
522
    maybe_doc_hdr
 
523
      = case exports of
 
524
          [] -> noHtml
 
525
          ExportGroup _ _ _ : _ -> noHtml
 
526
          _ -> h1 << "Documentation"
 
527
 
 
528
    bdy =
 
529
      foldr (+++) noHtml $
 
530
        mapMaybe (processExport False linksInfo unicode) exports
 
531
 
 
532
    linksInfo = (maybe_source_url, maybe_wiki_url)
 
533
 
 
534
 
 
535
miniSynopsis :: Module -> Interface -> Bool -> Html
 
536
miniSynopsis mdl iface unicode =
 
537
    divInterface << mapMaybe (processForMiniSynopsis mdl unicode) exports
 
538
  where
 
539
    exports = numberSectionHeadings (ifaceRnExportItems iface)
 
540
 
 
541
 
 
542
processForMiniSynopsis :: Module -> Bool -> ExportItem DocName -> Maybe Html
 
543
processForMiniSynopsis mdl unicode (ExportDecl (L _loc decl0) _doc _ _insts) =
 
544
  ((divTopDecl <<).(declElem <<)) `fmap` case decl0 of
 
545
    TyClD d -> let b = ppTyClBinderWithVarsMini mdl d in case d of
 
546
        (TyFamily{}) -> Just $ ppTyFamHeader True False d unicode
 
547
        (TyData{tcdTyPats = ps})
 
548
          | Nothing <- ps -> Just $ keyword "data" <+> b
 
549
          | Just _ <- ps  -> Just $ keyword "data" <+> keyword "instance" <+> b
 
550
        (TySynonym{tcdTyPats = ps})
 
551
          | Nothing <- ps -> Just $ keyword "type" <+> b
 
552
          | Just _ <- ps  -> Just $ keyword "type" <+> keyword "instance" <+> b
 
553
        (ClassDecl {})    -> Just $ keyword "class" <+> b
 
554
        _ -> Nothing
 
555
    SigD (TypeSig (L _ n) (L _ _)) ->
 
556
         Just $ ppNameMini mdl (docNameOcc n)
 
557
    _ -> Nothing
 
558
processForMiniSynopsis _ _ (ExportGroup lvl _id txt) =
 
559
  Just $ groupTag lvl << docToHtml txt
 
560
processForMiniSynopsis _ _ _ = Nothing
 
561
 
 
562
 
 
563
ppNameMini :: Module -> OccName -> Html
 
564
ppNameMini mdl nm =
 
565
    anchor ! [ href (moduleNameUrl mdl nm)
 
566
             , target mainFrameName ]
 
567
      << ppBinder' nm
 
568
 
 
569
 
 
570
ppTyClBinderWithVarsMini :: Module -> TyClDecl DocName -> Html
 
571
ppTyClBinderWithVarsMini mdl decl =
 
572
  let n = unLoc $ tcdLName decl
 
573
      ns = tyvarNames $ tcdTyVars decl
 
574
  in ppTypeApp n ns (ppNameMini mdl . docNameOcc) ppTyName
 
575
 
 
576
 
 
577
ppModuleContents :: [ExportItem DocName] -> Html
 
578
ppModuleContents exports
 
579
  | null sections = noHtml
 
580
  | otherwise     = contentsDiv
 
581
 where
 
582
  contentsDiv = divTableOfContents << (
 
583
    sectionName << "Contents" +++
 
584
    unordList sections)
 
585
 
 
586
  (sections, _leftovers{-should be []-}) = process 0 exports
 
587
 
 
588
  process :: Int -> [ExportItem DocName] -> ([Html],[ExportItem DocName])
 
589
  process _ [] = ([], [])
 
590
  process n items@(ExportGroup lev id0 doc : rest)
 
591
    | lev <= n  = ( [], items )
 
592
    | otherwise = ( html:secs, rest2 )
 
593
    where
 
594
        html = linkedAnchor id0 << docToHtml doc +++ mk_subsections ssecs
 
595
        (ssecs, rest1) = process lev rest
 
596
        (secs,  rest2) = process n   rest1
 
597
  process n (_ : rest) = process n rest
 
598
 
 
599
  mk_subsections [] = noHtml
 
600
  mk_subsections ss = unordList ss
 
601
 
 
602
 
 
603
-- we need to assign a unique id to each section heading so we can hyperlink
 
604
-- them from the contents:
 
605
numberSectionHeadings :: [ExportItem DocName] -> [ExportItem DocName]
 
606
numberSectionHeadings exports = go 1 exports
 
607
  where go :: Int -> [ExportItem DocName] -> [ExportItem DocName]
 
608
        go _ [] = []
 
609
        go n (ExportGroup lev _ doc : es)
 
610
          = ExportGroup lev (show n) doc : go (n+1) es
 
611
        go n (other:es)
 
612
          = other : go n es
 
613
 
 
614
 
 
615
processExport :: Bool -> LinksInfo -> Bool -> (ExportItem DocName) -> Maybe Html
 
616
processExport summary _ _ (ExportGroup lev id0 doc)
 
617
  = nothingIf summary $ groupTag lev ! [identifier id0] << docToHtml doc
 
618
processExport summary links unicode (ExportDecl decl doc subdocs insts)
 
619
  = processDecl summary $ ppDecl summary links decl doc insts subdocs unicode
 
620
processExport summary _ _ (ExportNoDecl y [])
 
621
  = processDeclOneLiner summary $ ppDocName y
 
622
processExport summary _ _ (ExportNoDecl y subs)
 
623
  = processDeclOneLiner summary $ ppDocName y +++ parenList (map ppDocName subs)
 
624
processExport summary _ _ (ExportDoc doc)
 
625
  = nothingIf summary $ docSection doc
 
626
processExport summary _ _ (ExportModule mdl)
 
627
  = processDeclOneLiner summary $ toHtml "module" <+> ppModule mdl
 
628
 
 
629
 
 
630
nothingIf :: Bool -> a -> Maybe a
 
631
nothingIf True _ = Nothing
 
632
nothingIf False a = Just a
 
633
 
 
634
 
 
635
processDecl :: Bool -> Html -> Maybe Html
 
636
processDecl True = Just
 
637
processDecl False = Just . divTopDecl
 
638
 
 
639
 
 
640
processDeclOneLiner :: Bool -> Html -> Maybe Html
 
641
processDeclOneLiner True = Just
 
642
processDeclOneLiner False = Just . divTopDecl . declElem
 
643
 
 
644
 
 
645
groupTag :: Int -> Html -> Html
 
646
groupTag lev
 
647
  | lev == 1  = h1
 
648
  | lev == 2  = h2
 
649
  | lev == 3  = h3
 
650
  | otherwise = h4
 
651
 
 
652