1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
|
-----------------------------------------------------------------------------
-- |
-- Module : Haddock.Backends.Html.DocMarkup
-- 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.DocMarkup (
docToHtml,
rdrDocToHtml,
origDocToHtml,
docElement, docSection, docSection_,
) where
import Control.Applicative ((<$>))
import Haddock.Backends.Xhtml.Names
import Haddock.Backends.Xhtml.Utils
import Haddock.Types
import Haddock.Utils
import Haddock.Doc (combineDocumentation)
import Text.XHtml hiding ( name, p, quote )
import Data.Maybe (fromMaybe)
import GHC
parHtmlMarkup :: Qualification -> (a -> Html) -> DocMarkup a Html
parHtmlMarkup qual ppId = Markup {
markupEmpty = noHtml,
markupString = toHtml,
markupParagraph = paragraph,
markupAppend = (+++),
markupIdentifier = thecode . ppId,
markupIdentifierUnchecked = thecode . ppUncheckedLink qual,
markupModule = \m -> let (mdl,ref) = break (=='#') m
in ppModuleRef (mkModuleName mdl) ref,
markupWarning = thediv ! [theclass "warning"],
markupEmphasis = emphasize,
markupBold = strong,
markupMonospaced = thecode,
markupUnorderedList = unordList,
markupOrderedList = ordList,
markupDefList = defList,
markupCodeBlock = pre,
markupHyperlink = \(Hyperlink url mLabel) -> anchor ! [href url] << fromMaybe url mLabel,
markupAName = \aname -> namedAnchor aname << "",
markupPic = \(Picture uri t) -> image ! ([src uri] ++ fromMaybe [] (return . title <$> t)),
markupProperty = pre . toHtml,
markupExample = examplesToHtml,
markupHeader = \(Header l t) -> makeHeader l t
}
where
makeHeader :: Int -> Html -> Html
makeHeader 1 mkup = h1 mkup
makeHeader 2 mkup = h2 mkup
makeHeader 3 mkup = h3 mkup
makeHeader 4 mkup = h4 mkup
makeHeader 5 mkup = h5 mkup
makeHeader 6 mkup = h6 mkup
makeHeader l _ = error $ "Somehow got a header level `" ++ show l ++ "' in DocMarkup!"
examplesToHtml l = pre (concatHtml $ map exampleToHtml l) ! [theclass "screen"]
exampleToHtml (Example expression result) = htmlExample
where
htmlExample = htmlPrompt +++ htmlExpression +++ toHtml (unlines result)
htmlPrompt = (thecode . toHtml $ ">>> ") ! [theclass "prompt"]
htmlExpression = (strong . thecode . toHtml $ expression ++ "\n") ! [theclass "userinput"]
-- If the doc is a single paragraph, don't surround it with <P> (this causes
-- ugly extra whitespace with some browsers). FIXME: Does this still apply?
docToHtml :: Qualification -> Doc DocName -> Html
docToHtml qual = markup fmt . cleanup
where fmt = parHtmlMarkup qual (ppDocName qual Raw)
origDocToHtml :: Qualification -> Doc Name -> Html
origDocToHtml qual = markup fmt . cleanup
where fmt = parHtmlMarkup qual (ppName Raw)
rdrDocToHtml :: Qualification -> Doc RdrName -> Html
rdrDocToHtml qual = markup fmt . cleanup
where fmt = parHtmlMarkup qual ppRdrName
docElement :: (Html -> Html) -> Html -> Html
docElement el content_ =
if isNoHtml content_
then el ! [theclass "doc empty"] << spaceHtml
else el ! [theclass "doc"] << content_
docSection :: Qualification -> Documentation DocName -> Html
docSection qual = maybe noHtml (docSection_ qual) . combineDocumentation
docSection_ :: Qualification -> Doc DocName -> Html
docSection_ qual = (docElement thediv <<) . docToHtml qual
cleanup :: Doc a -> Doc a
cleanup = markup fmtUnParagraphLists
where
-- If there is a single paragraph, then surrounding it with <P>..</P>
-- can add too much whitespace in some browsers (eg. IE). However if
-- we have multiple paragraphs, then we want the extra whitespace to
-- separate them. So we catch the single paragraph case and transform it
-- here. We don't do this in code blocks as it eliminates line breaks.
unParagraph :: Doc a -> Doc a
unParagraph (DocParagraph d) = d
unParagraph doc = doc
fmtUnParagraphLists :: DocMarkup a (Doc a)
fmtUnParagraphLists = idMarkup {
markupUnorderedList = DocUnorderedList . map unParagraph,
markupOrderedList = DocOrderedList . map unParagraph
}
|
