1-----------------------------------------------------------------------------
2-- |
3-- Module      :  Haddock.Backends.Html
4-- Copyright   :  (c) Simon Marlow      2003-2006,
5--                    David Waern       2006-2009,
6--                    Mark Lentczner    2010,
7--                    Mateusz Kowalczyk 2013
8-- License     :  BSD-like
9--
10-- Maintainer  :  haddock@projects.haskell.org
11-- Stability   :  experimental
12-- Portability :  portable
13-----------------------------------------------------------------------------
14{-# LANGUAGE CPP, NamedFieldPuns #-}
15module Haddock.Backends.Xhtml (
16  ppHtml, copyHtmlBits,
17  ppHtmlIndex, ppHtmlContents,
18) where
19
20
21import Prelude hiding (div)
22
23import Haddock.Backends.Xhtml.Decl
24import Haddock.Backends.Xhtml.DocMarkup
25import Haddock.Backends.Xhtml.Layout
26import Haddock.Backends.Xhtml.Names
27import Haddock.Backends.Xhtml.Themes
28import Haddock.Backends.Xhtml.Types
29import Haddock.Backends.Xhtml.Utils
30import Haddock.ModuleTree
31import Haddock.Types
32import Haddock.Version
33import Haddock.Utils
34import Haddock.Utils.Json
35import Text.XHtml hiding ( name, title, p, quote )
36import qualified Text.XHtml as XHtml
37import Haddock.GhcUtils
38
39import Control.Monad         ( when, unless )
40import qualified Data.ByteString.Builder as Builder
41import Data.Char             ( toUpper, isSpace )
42import Data.List             ( sortBy, isPrefixOf, intersperse )
43import Data.Maybe
44import System.Directory
45import System.FilePath hiding ( (</>) )
46import qualified System.IO as IO
47import Data.Map              ( Map )
48import qualified Data.Map as Map hiding ( Map )
49import qualified Data.Set as Set hiding ( Set )
50import Data.Ord              ( comparing )
51
52import GHC hiding ( NoLink, moduleInfo,LexicalFixity(..) )
53import Name
54
55--------------------------------------------------------------------------------
56-- * Generating HTML documentation
57--------------------------------------------------------------------------------
58
59ppHtml :: DynFlags
60       -> String                       -- ^ Title
61       -> Maybe String                 -- ^ Package
62       -> [Interface]
63       -> [InstalledInterface]         -- ^ Reexported interfaces
64       -> FilePath                     -- ^ Destination directory
65       -> Maybe (MDoc GHC.RdrName)     -- ^ Prologue text, maybe
66       -> Themes                       -- ^ Themes
67       -> Maybe String                 -- ^ The mathjax URL (--mathjax)
68       -> SourceURLs                   -- ^ The source URL (--source)
69       -> WikiURLs                     -- ^ The wiki URL (--wiki)
70       -> Maybe String                 -- ^ The contents URL (--use-contents)
71       -> Maybe String                 -- ^ The index URL (--use-index)
72       -> Bool                         -- ^ Whether to use unicode in output (--use-unicode)
73       -> Maybe String                 -- ^ Package name
74       -> QualOption                   -- ^ How to qualify names
75       -> Bool                         -- ^ Output pretty html (newlines and indenting)
76       -> Bool                         -- ^ Also write Quickjump index
77       -> IO ()
78
79ppHtml dflags doctitle maybe_package ifaces reexported_ifaces odir prologue
80        themes maybe_mathjax_url maybe_source_url maybe_wiki_url
81        maybe_contents_url maybe_index_url unicode
82        pkg qual debug withQuickjump = do
83  let
84    visible_ifaces = filter visible ifaces
85    visible i = OptHide `notElem` ifaceOptions i
86
87  when (isNothing maybe_contents_url) $
88    ppHtmlContents dflags odir doctitle maybe_package
89        themes maybe_mathjax_url maybe_index_url maybe_source_url maybe_wiki_url
90        (map toInstalledIface visible_ifaces ++ reexported_ifaces)
91        False -- we don't want to display the packages in a single-package contents
92        prologue debug pkg (makeContentsQual qual)
93
94  when (isNothing maybe_index_url) $ do
95    ppHtmlIndex odir doctitle maybe_package
96      themes maybe_mathjax_url maybe_contents_url maybe_source_url maybe_wiki_url
97      (map toInstalledIface visible_ifaces ++ reexported_ifaces) debug
98
99    when withQuickjump $
100      ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual
101        visible_ifaces
102
103  mapM_ (ppHtmlModule odir doctitle themes
104           maybe_mathjax_url maybe_source_url maybe_wiki_url
105           maybe_contents_url maybe_index_url unicode pkg qual debug) visible_ifaces
106
107
108copyHtmlBits :: FilePath -> FilePath -> Themes -> Bool -> IO ()
109copyHtmlBits odir libdir themes withQuickjump = do
110  let
111    libhtmldir = joinPath [libdir, "html"]
112    copyCssFile f = copyFile f (combine odir (takeFileName f))
113    copyLibFile f = copyFile (joinPath [libhtmldir, f]) (joinPath [odir, f])
114  mapM_ copyCssFile (cssFiles themes)
115  copyLibFile haddockJsFile
116  copyCssFile (joinPath [libhtmldir, quickJumpCssFile])
117  when withQuickjump (copyLibFile jsQuickJumpFile)
118  return ()
119
120
121headHtml :: String -> Themes -> Maybe String -> Html
122headHtml docTitle themes mathjax_url =
123  header <<
124    [ meta ! [ httpequiv "Content-Type", content "text/html; charset=UTF-8"]
125    , meta ! [ XHtml.name "viewport", content "width=device-width, initial-scale=1"]
126    , thetitle << docTitle
127    , styleSheet themes
128    , thelink ! [ rel "stylesheet", thetype "text/css", href quickJumpCssFile] << noHtml
129    , thelink ! [ rel "stylesheet", thetype "text/css", href fontUrl] << noHtml
130    , script ! [src haddockJsFile, emptyAttr "async", thetype "text/javascript"] << noHtml
131    , script ! [thetype "text/x-mathjax-config"] << primHtml mjConf
132    , script ! [src mjUrl, thetype "text/javascript"] << noHtml
133    ]
134  where
135    fontUrl = "https://fonts.googleapis.com/css?family=PT+Sans:400,400i,700"
136    mjUrl = fromMaybe "https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.5/MathJax.js?config=TeX-AMS-MML_HTMLorMML" mathjax_url
137    mjConf = unwords [ "MathJax.Hub.Config({"
138                     ,   "tex2jax: {"
139                     ,     "processClass: \"mathjax\","
140                     ,     "ignoreClass: \".*\""
141                     ,   "}"
142                     , "});" ]
143
144srcButton :: SourceURLs -> Maybe Interface -> Maybe Html
145srcButton (Just src_base_url, _, _, _) Nothing =
146  Just (anchor ! [href src_base_url] << "Source")
147srcButton (_, Just src_module_url, _, _) (Just iface) =
148  let url = spliceURL (Just $ ifaceOrigFilename iface)
149                      (Just $ ifaceMod iface) Nothing Nothing src_module_url
150   in Just (anchor ! [href url] << "Source")
151srcButton _ _ =
152  Nothing
153
154
155wikiButton :: WikiURLs -> Maybe Module -> Maybe Html
156wikiButton (Just wiki_base_url, _, _) Nothing =
157  Just (anchor ! [href wiki_base_url] << "User Comments")
158
159wikiButton (_, Just wiki_module_url, _) (Just mdl) =
160  let url = spliceURL Nothing (Just mdl) Nothing Nothing wiki_module_url
161   in Just (anchor ! [href url] << "User Comments")
162
163wikiButton _ _ =
164  Nothing
165
166
167contentsButton :: Maybe String -> Maybe Html
168contentsButton maybe_contents_url
169  = Just (anchor ! [href url] << "Contents")
170  where url = fromMaybe contentsHtmlFile maybe_contents_url
171
172
173indexButton :: Maybe String -> Maybe Html
174indexButton maybe_index_url
175  = Just (anchor ! [href url] << "Index")
176  where url = fromMaybe indexHtmlFile maybe_index_url
177
178
179bodyHtml :: String -> Maybe Interface
180    -> SourceURLs -> WikiURLs
181    -> Maybe String -> Maybe String
182    -> Html -> Html
183bodyHtml doctitle iface
184           maybe_source_url maybe_wiki_url
185           maybe_contents_url maybe_index_url
186           pageContent =
187  body << [
188    divPackageHeader << [
189      nonEmptySectionName << doctitle,
190      unordList (catMaybes [
191        srcButton maybe_source_url iface,
192        wikiButton maybe_wiki_url (ifaceMod <$> iface),
193        contentsButton maybe_contents_url,
194        indexButton maybe_index_url])
195            ! [theclass "links", identifier "page-menu"]
196      ],
197    divContent << pageContent,
198    divFooter << paragraph << (
199      "Produced by " +++
200      (anchor ! [href projectUrl] << toHtml projectName) +++
201      (" version " ++ projectVersion)
202      )
203    ]
204
205moduleInfo :: Interface -> Html
206moduleInfo iface =
207   let
208      info = ifaceInfo iface
209
210      doOneEntry :: (String, HaddockModInfo GHC.Name -> Maybe String) -> Maybe HtmlTable
211      doOneEntry (fieldName, field) =
212        field info >>= \a -> return (th << fieldName <-> td << a)
213
214      entries :: [HtmlTable]
215      entries = maybeToList copyrightsTable ++ mapMaybe doOneEntry [
216          ("License",hmi_license),
217          ("Maintainer",hmi_maintainer),
218          ("Stability",hmi_stability),
219          ("Portability",hmi_portability),
220          ("Safe Haskell",hmi_safety),
221          ("Language", lg)
222          ] ++ extsForm
223        where
224          lg inf = fmap show (hmi_language inf)
225
226          multilineRow :: String -> [String] -> HtmlTable
227          multilineRow title xs = (th ! [valign "top"]) << title <-> td << (toLines xs)
228            where toLines = mconcat . intersperse br . map toHtml
229
230          copyrightsTable :: Maybe HtmlTable
231          copyrightsTable = fmap (multilineRow "Copyright" . split) (hmi_copyright info)
232            where split = map (trim . filter (/= ',')) . lines
233
234          extsForm
235            | OptShowExtensions `elem` ifaceOptions iface =
236              let fs = map (dropOpt . show) (hmi_extensions info)
237              in case map stringToHtml fs of
238                [] -> []
239                [x] -> extField x -- don't use a list for a single extension
240                xs -> extField $ unordList xs ! [theclass "extension-list"]
241            | otherwise = []
242            where
243              extField x = return $ th << "Extensions" <-> td << x
244              dropOpt x = if "Opt_" `isPrefixOf` x then drop 4 x else x
245   in
246      case entries of
247         [] -> noHtml
248         _ -> table ! [theclass "info"] << aboves entries
249
250
251--------------------------------------------------------------------------------
252-- * Generate the module contents
253--------------------------------------------------------------------------------
254
255
256ppHtmlContents
257   :: DynFlags
258   -> FilePath
259   -> String
260   -> Maybe String
261   -> Themes
262   -> Maybe String
263   -> Maybe String
264   -> SourceURLs
265   -> WikiURLs
266   -> [InstalledInterface] -> Bool -> Maybe (MDoc GHC.RdrName)
267   -> Bool
268   -> Maybe Package  -- ^ Current package
269   -> Qualification  -- ^ How to qualify names
270   -> IO ()
271ppHtmlContents dflags odir doctitle _maybe_package
272  themes mathjax_url maybe_index_url
273  maybe_source_url maybe_wiki_url ifaces showPkgs prologue debug pkg qual = do
274  let tree = mkModuleTree dflags showPkgs
275         [(instMod iface, toInstalledDescription iface)
276         | iface <- ifaces
277         , not (instIsSig iface)]
278      sig_tree = mkModuleTree dflags showPkgs
279         [(instMod iface, toInstalledDescription iface)
280         | iface <- ifaces
281         , instIsSig iface]
282      html =
283        headHtml doctitle themes mathjax_url +++
284        bodyHtml doctitle Nothing
285          maybe_source_url maybe_wiki_url
286          Nothing maybe_index_url << [
287            ppPrologue pkg qual doctitle prologue,
288            ppSignatureTree pkg qual sig_tree,
289            ppModuleTree pkg qual tree
290          ]
291  createDirectoryIfMissing True odir
292  writeUtf8File (joinPath [odir, contentsHtmlFile]) (renderToString debug html)
293  where
294    -- Extract a module's short description.
295    toInstalledDescription :: InstalledInterface -> Maybe (MDoc Name)
296    toInstalledDescription = fmap mkMeta . hmi_description . instInfo
297
298
299ppPrologue :: Maybe Package -> Qualification -> String -> Maybe (MDoc GHC.RdrName) -> Html
300ppPrologue _ _ _ Nothing = noHtml
301ppPrologue pkg qual title (Just doc) =
302  divDescription << (h1 << title +++ docElement thediv (rdrDocToHtml pkg qual doc))
303
304
305ppSignatureTree :: Maybe Package -> Qualification -> [ModuleTree] -> Html
306ppSignatureTree _ _ [] = mempty
307ppSignatureTree pkg qual ts =
308  divModuleList << (sectionName << "Signatures" +++ mkNodeList pkg qual [] "n" ts)
309
310
311ppModuleTree :: Maybe Package -> Qualification -> [ModuleTree] -> Html
312ppModuleTree _ _ [] = mempty
313ppModuleTree pkg qual ts =
314  divModuleList << (sectionName << "Modules" +++ mkNodeList pkg qual [] "n" ts)
315
316
317mkNodeList :: Maybe Package -> Qualification -> [String] -> String -> [ModuleTree] -> Html
318mkNodeList pkg qual ss p ts = case ts of
319  [] -> noHtml
320  _ -> unordList (zipWith (mkNode pkg qual ss) ps ts)
321  where
322    ps = [ p ++ '.' : show i | i <- [(1::Int)..]]
323
324
325mkNode :: Maybe Package -> Qualification -> [String] -> String -> ModuleTree -> Html
326mkNode pkg qual ss p (Node s leaf _pkg srcPkg short ts) =
327  htmlModule <+> shortDescr +++ htmlPkg +++ subtree
328  where
329    modAttrs = case (ts, leaf) of
330      (_:_, Nothing) -> collapseControl p "module"
331      (_,   _    ) -> [theclass "module"]
332
333    cBtn = case (ts, leaf) of
334      (_:_, Just _) -> thespan ! collapseControl p "" << spaceHtml
335      ([] , Just _) -> thespan ! [theclass "noexpander"] << spaceHtml
336      (_,   _   ) -> noHtml
337      -- We only need an explicit collapser button when the module name
338      -- is also a leaf, and so is a link to a module page. Indeed, the
339      -- spaceHtml is a minor hack and does upset the layout a fraction.
340
341    htmlModule = thespan ! modAttrs << (cBtn +++
342      case leaf of
343        Just m -> ppModule m
344        Nothing -> toHtml s
345      )
346
347    shortDescr = maybe noHtml (origDocToHtml pkg qual) short
348    htmlPkg = maybe noHtml (thespan ! [theclass "package"] <<) srcPkg
349
350    subtree =
351      if null ts then noHtml else
352      collapseDetails p DetailsOpen (
353        thesummary ! [ theclass "hide-when-js-enabled" ] << "Submodules" +++
354        mkNodeList pkg qual (s:ss) p ts
355      )
356
357
358
359--------------------------------------------------------------------------------
360-- * Generate the index
361--------------------------------------------------------------------------------
362
363ppJsonIndex :: FilePath
364           -> SourceURLs                   -- ^ The source URL (--source)
365           -> WikiURLs                     -- ^ The wiki URL (--wiki)
366           -> Bool
367           -> Maybe Package
368           -> QualOption
369           -> [Interface]
370           -> IO ()
371ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual_opt ifaces = do
372  createDirectoryIfMissing True odir
373  IO.withBinaryFile (joinPath [odir, indexJsonFile]) IO.WriteMode $ \h -> do
374    Builder.hPutBuilder h (encodeToBuilder modules)
375  where
376    modules :: Value
377    modules = Array (concatMap goInterface ifaces)
378
379    goInterface :: Interface -> [Value]
380    goInterface iface =
381        concatMap (goExport mdl qual) (ifaceRnExportItems iface)
382      where
383        aliases = ifaceModuleAliases iface
384        qual    = makeModuleQual qual_opt aliases mdl
385        mdl     = ifaceMod iface
386
387    goExport :: Module -> Qualification -> ExportItem DocNameI -> [Value]
388    goExport mdl qual item
389      | Just item_html <- processExport True links_info unicode pkg qual item
390      = [ Object
391            [ "display_html" .= String (showHtmlFragment item_html)
392            , "name"         .= String (unwords (map getOccString names))
393            , "module"       .= String (moduleString mdl)
394            , "link"         .= String (fromMaybe "" (listToMaybe (map (nameLink mdl) names)))
395            ]
396        ]
397      | otherwise = []
398      where
399        names = exportName item ++ exportSubs item
400
401    exportSubs :: ExportItem DocNameI -> [IdP DocNameI]
402    exportSubs ExportDecl { expItemSubDocs } = map fst expItemSubDocs
403    exportSubs _ = []
404
405    exportName :: ExportItem DocNameI -> [IdP DocNameI]
406    exportName ExportDecl { expItemDecl } = getMainDeclBinderI (unLoc expItemDecl)
407    exportName ExportNoDecl { expItemName } = [expItemName]
408    exportName _ = []
409
410    nameLink :: NamedThing name => Module -> name -> String
411    nameLink mdl = moduleNameUrl' (moduleName mdl) . nameOccName . getName
412
413    links_info = (maybe_source_url, maybe_wiki_url)
414
415ppHtmlIndex :: FilePath
416            -> String
417            -> Maybe String
418            -> Themes
419            -> Maybe String
420            -> Maybe String
421            -> SourceURLs
422            -> WikiURLs
423            -> [InstalledInterface]
424            -> Bool
425            -> IO ()
426ppHtmlIndex odir doctitle _maybe_package themes
427  maybe_mathjax_url maybe_contents_url maybe_source_url maybe_wiki_url ifaces debug = do
428  let html = indexPage split_indices Nothing
429              (if split_indices then [] else index)
430
431  createDirectoryIfMissing True odir
432
433  when split_indices $ do
434    mapM_ (do_sub_index index) initialChars
435    -- Let's add a single large index as well for those who don't know exactly what they're looking for:
436    let mergedhtml = indexPage False Nothing index
437    writeUtf8File (joinPath [odir, subIndexHtmlFile merged_name]) (renderToString debug mergedhtml)
438
439  writeUtf8File (joinPath [odir, indexHtmlFile]) (renderToString debug html)
440
441  where
442    indexPage showLetters ch items =
443      headHtml (doctitle ++ " (" ++ indexName ch ++ ")") themes maybe_mathjax_url +++
444      bodyHtml doctitle Nothing
445        maybe_source_url maybe_wiki_url
446        maybe_contents_url Nothing << [
447          if showLetters then indexInitialLetterLinks else noHtml,
448          if null items then noHtml else
449            divIndex << [sectionName << indexName ch, buildIndex items]
450          ]
451
452    indexName ch = "Index" ++ maybe "" (\c -> " - " ++ [c]) ch
453    merged_name = "All"
454
455    buildIndex items = table << aboves (map indexElt items)
456
457    -- an arbitrary heuristic:
458    -- too large, and a single-page will be slow to load
459    -- too small, and we'll have lots of letter-indexes with only one
460    --   or two members in them, which seems inefficient or
461    --   unnecessarily hard to use.
462    split_indices = length index > 150
463
464    indexInitialLetterLinks =
465      divAlphabet <<
466         unordList (map (\str -> anchor ! [href (subIndexHtmlFile str)] << str) $
467                        [ [c] | c <- initialChars
468                              , any ((==c) . toUpper . head . fst) index ] ++
469                        [merged_name])
470
471    -- todo: what about names/operators that start with Unicode
472    -- characters?
473    -- Exports beginning with '_' can be listed near the end,
474    -- presumably they're not as important... but would be listed
475    -- with non-split index!
476    initialChars = [ 'A'..'Z' ] ++ ":!#$%&*+./<=>?@\\^|-~" ++ "_"
477
478    do_sub_index this_ix c
479      = unless (null index_part) $
480          writeUtf8File (joinPath [odir, subIndexHtmlFile [c]]) (renderToString debug html)
481      where
482        html = indexPage True (Just c) index_part
483        index_part = [(n,stuff) | (n,stuff) <- this_ix, toUpper (head n) == c]
484
485
486    index :: [(String, Map GHC.Name [(Module,Bool)])]
487    index = sortBy cmp (Map.toAscList full_index)
488      where cmp (n1,_) (n2,_) = comparing (map toUpper) n1 n2
489
490    -- for each name (a plain string), we have a number of original HsNames that
491    -- it can refer to, and for each of those we have a list of modules
492    -- that export that entity.  Each of the modules exports the entity
493    -- in a visible or invisible way (hence the Bool).
494    full_index :: Map String (Map GHC.Name [(Module,Bool)])
495    full_index = Map.fromListWith (flip (Map.unionWith (++)))
496                 (concatMap getIfaceIndex ifaces)
497
498    getIfaceIndex iface =
499      [ (getOccString name
500         , Map.fromList [(name, [(mdl, name `Set.member` visible)])])
501         | name <- instExports iface ]
502      where
503        mdl = instMod iface
504        visible = Set.fromList (instVisibleExports iface)
505
506    indexElt :: (String, Map GHC.Name [(Module,Bool)]) -> HtmlTable
507    indexElt (str, entities) =
508       case Map.toAscList entities of
509          [(nm,entries)] ->
510              td ! [ theclass "src" ] << toHtml str <->
511                          indexLinks nm entries
512          many_entities ->
513              td ! [ theclass "src" ] << toHtml str <-> td << spaceHtml </>
514                  aboves (zipWith (curry doAnnotatedEntity) [1..] many_entities)
515
516    doAnnotatedEntity :: (Integer, (Name, [(Module, Bool)])) -> HtmlTable
517    doAnnotatedEntity (j,(nm,entries))
518          = td ! [ theclass "alt" ] <<
519                  toHtml (show j) <+> parens (ppAnnot (nameOccName nm)) <->
520                   indexLinks nm entries
521
522    ppAnnot n | not (isValOcc n) = toHtml "Type/Class"
523              | isDataOcc n      = toHtml "Data Constructor"
524              | otherwise        = toHtml "Function"
525
526    indexLinks nm entries =
527       td ! [ theclass "module" ] <<
528          hsep (punctuate comma
529          [ if visible then
530               linkId mdl (Just nm) << toHtml (moduleString mdl)
531            else
532               toHtml (moduleString mdl)
533          | (mdl, visible) <- entries ])
534
535
536--------------------------------------------------------------------------------
537-- * Generate the HTML page for a module
538--------------------------------------------------------------------------------
539
540
541ppHtmlModule
542        :: FilePath -> String -> Themes
543        -> Maybe String -> SourceURLs -> WikiURLs
544        -> Maybe String -> Maybe String -> Bool -> Maybe Package -> QualOption
545        -> Bool -> Interface -> IO ()
546ppHtmlModule odir doctitle themes
547  maybe_mathjax_url maybe_source_url maybe_wiki_url
548  maybe_contents_url maybe_index_url unicode pkg qual debug iface = do
549  let
550      mdl = ifaceMod iface
551      aliases = ifaceModuleAliases iface
552      mdl_str = moduleString mdl
553      mdl_str_annot = mdl_str ++ if ifaceIsSig iface
554                                    then " (signature)"
555                                    else ""
556      mdl_str_linked
557        | ifaceIsSig iface
558        = mdl_str +++ " (signature" +++
559                       sup << ("[" +++ anchor ! [href signatureDocURL] << "?" +++ "]" ) +++
560                       ")"
561        | otherwise
562        = toHtml mdl_str
563      real_qual = makeModuleQual qual aliases mdl
564      html =
565        headHtml mdl_str_annot themes maybe_mathjax_url +++
566        bodyHtml doctitle (Just iface)
567          maybe_source_url maybe_wiki_url
568          maybe_contents_url maybe_index_url << [
569            divModuleHeader << (moduleInfo iface +++ (sectionName << mdl_str_linked)),
570            ifaceToHtml maybe_source_url maybe_wiki_url iface unicode pkg real_qual
571          ]
572
573  createDirectoryIfMissing True odir
574  writeUtf8File (joinPath [odir, moduleHtmlFile mdl]) (renderToString debug html)
575
576signatureDocURL :: String
577signatureDocURL = "https://wiki.haskell.org/Module_signature"
578
579
580ifaceToHtml :: SourceURLs -> WikiURLs -> Interface -> Bool -> Maybe Package -> Qualification -> Html
581ifaceToHtml maybe_source_url maybe_wiki_url iface unicode pkg qual
582  = ppModuleContents pkg qual exports (not . null $ ifaceRnOrphanInstances iface) +++
583    description +++
584    synopsis +++
585    divInterface (maybe_doc_hdr +++ bdy +++ orphans)
586  where
587    exports = numberSectionHeadings (ifaceRnExportItems iface)
588
589    -- todo: if something has only sub-docs, or fn-args-docs, should
590    -- it be measured here and thus prevent omitting the synopsis?
591    has_doc ExportDecl { expItemMbDoc = (Documentation mDoc mWarning, _) } = isJust mDoc || isJust mWarning
592    has_doc (ExportNoDecl _ _) = False
593    has_doc (ExportModule _) = False
594    has_doc _ = True
595
596    no_doc_at_all = not (any has_doc exports)
597
598    description | isNoHtml doc = doc
599                | otherwise    = divDescription $ sectionName << "Description" +++ doc
600                where doc = docSection Nothing pkg qual (ifaceRnDoc iface)
601
602        -- omit the synopsis if there are no documentation annotations at all
603    synopsis
604      | no_doc_at_all = noHtml
605      | otherwise
606      = divSynopsis $
607            collapseDetails "syn" DetailsClosed (
608              thesummary << "Synopsis" +++
609              shortDeclList (
610                  mapMaybe (processExport True linksInfo unicode pkg qual) exports
611              ) ! collapseToggle "syn" ""
612            )
613
614        -- if the documentation doesn't begin with a section header, then
615        -- add one ("Documentation").
616    maybe_doc_hdr
617      = case exports of
618          [] -> noHtml
619          ExportGroup {} : _ -> noHtml
620          _ -> h1 << "Documentation"
621
622    bdy =
623      foldr (+++) noHtml $
624        mapMaybe (processExport False linksInfo unicode pkg qual) exports
625
626    orphans =
627      ppOrphanInstances linksInfo (ifaceRnOrphanInstances iface) False unicode pkg qual
628
629    linksInfo = (maybe_source_url, maybe_wiki_url)
630
631
632ppModuleContents :: Maybe Package -- ^ This package
633                 -> Qualification
634                 -> [ExportItem DocNameI]
635                 -> Bool          -- ^ Orphans sections
636                 -> Html
637ppModuleContents pkg qual exports orphan
638  | null sections && not orphan  = noHtml
639  | otherwise                    = contentsDiv
640 where
641  contentsDiv = divTableOfContents << (divContentsList << (
642    (sectionName << "Contents") ! [ strAttr "onclick" "window.scrollTo(0,0)" ] +++
643    unordList (sections ++ orphanSection)))
644
645  (sections, _leftovers{-should be []-}) = process 0 exports
646  orphanSection
647    | orphan =  [ linkedAnchor "section.orphans" << "Orphan instances" ]
648    | otherwise = []
649
650  process :: Int -> [ExportItem DocNameI] -> ([Html],[ExportItem DocNameI])
651  process _ [] = ([], [])
652  process n items@(ExportGroup lev id0 doc : rest)
653    | lev <= n  = ( [], items )
654    | otherwise = ( html:secs, rest2 )
655    where
656      html = linkedAnchor (groupId id0)
657             << docToHtmlNoAnchors (Just id0) pkg qual (mkMeta doc) +++ mk_subsections ssecs
658      (ssecs, rest1) = process lev rest
659      (secs,  rest2) = process n   rest1
660  process n (_ : rest) = process n rest
661
662  mk_subsections [] = noHtml
663  mk_subsections ss = unordList ss
664
665-- we need to assign a unique id to each section heading so we can hyperlink
666-- them from the contents:
667numberSectionHeadings :: [ExportItem DocNameI] -> [ExportItem DocNameI]
668numberSectionHeadings = go 1
669  where go :: Int -> [ExportItem DocNameI] -> [ExportItem DocNameI]
670        go _ [] = []
671        go n (ExportGroup lev _ doc : es)
672          = case collectAnchors doc of
673              [] -> ExportGroup lev (show n) doc : go (n+1) es
674              (a:_) -> ExportGroup lev a doc : go (n+1) es
675        go n (other:es)
676          = other : go n es
677
678        collectAnchors :: DocH (Wrap (ModuleName, OccName)) (Wrap DocName) -> [String]
679        collectAnchors (DocAppend a b) = collectAnchors a ++ collectAnchors b
680        collectAnchors (DocAName a) = [a]
681        collectAnchors _ = []
682
683processExport :: Bool -> LinksInfo -> Bool -> Maybe Package -> Qualification
684              -> ExportItem DocNameI -> Maybe Html
685processExport _ _ _ _ _ ExportDecl { expItemDecl = L _ (InstD {}) } = Nothing -- Hide empty instances
686processExport summary _ _ pkg qual (ExportGroup lev id0 doc)
687  = nothingIf summary $ groupHeading lev id0 << docToHtmlNoAnchors (Just id0) pkg qual (mkMeta doc)
688processExport summary links unicode pkg qual (ExportDecl decl pats doc subdocs insts fixities splice)
689  = processDecl summary $ ppDecl summary links decl pats doc insts fixities subdocs splice unicode pkg qual
690processExport summary _ _ _ qual (ExportNoDecl y [])
691  = processDeclOneLiner summary $ ppDocName qual Prefix True y
692processExport summary _ _ _ qual (ExportNoDecl y subs)
693  = processDeclOneLiner summary $
694      ppDocName qual Prefix True y
695      +++ parenList (map (ppDocName qual Prefix True) subs)
696processExport summary _ _ pkg qual (ExportDoc doc)
697  = nothingIf summary $ docSection_ Nothing pkg qual doc
698processExport summary _ _ _ _ (ExportModule mdl)
699  = processDeclOneLiner summary $ toHtml "module" <+> ppModule mdl
700
701
702nothingIf :: Bool -> a -> Maybe a
703nothingIf True _ = Nothing
704nothingIf False a = Just a
705
706
707processDecl :: Bool -> Html -> Maybe Html
708processDecl True = Just
709processDecl False = Just . divTopDecl
710
711trim :: String -> String
712trim = f . f
713  where f = reverse . dropWhile isSpace
714
715processDeclOneLiner :: Bool -> Html -> Maybe Html
716processDeclOneLiner True = Just
717processDeclOneLiner False = Just . divTopDecl . declElem
718
719groupHeading :: Int -> String -> Html -> Html
720groupHeading lev id0 = linkedAnchor grpId . groupTag lev ! [identifier grpId]
721  where grpId = groupId id0
722
723groupTag :: Int -> Html -> Html
724groupTag lev
725  | lev == 1  = h1
726  | lev == 2  = h2
727  | lev == 3  = h3
728  | otherwise = h4
729