blob: 4d68c554fd3aae4c28d9a74e049649392d359af3 (
plain) (
blame)
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
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Haddock.Doc (
docAppend,
docParagraph,
combineStringNodes,
combineDocumentation
) where
import Data.Maybe
import Data.Monoid
import Haddock.Types
import Data.Char (isSpace)
import Control.Arrow ((***))
-- We put it here so that we can avoid a circular import
-- anything relevant imports this module anyway
instance Monoid (Doc id) where
mempty = DocEmpty
mappend = docAppend
combineDocumentation :: Documentation name -> Maybe (Doc name)
combineDocumentation (Documentation Nothing Nothing) = Nothing
combineDocumentation (Documentation mDoc mWarning) = Just (fromMaybe mempty mWarning `mappend` fromMaybe mempty mDoc)
-- used to make parsing easier; we group the list items later
docAppend :: Doc id -> Doc id -> Doc id
docAppend (DocUnorderedList ds1) (DocUnorderedList ds2)
= DocUnorderedList (ds1++ds2)
docAppend (DocUnorderedList ds1) (DocAppend (DocUnorderedList ds2) d)
= DocAppend (DocUnorderedList (ds1++ds2)) d
docAppend (DocOrderedList ds1) (DocOrderedList ds2)
= DocOrderedList (ds1++ds2)
docAppend (DocOrderedList ds1) (DocAppend (DocOrderedList ds2) d)
= DocAppend (DocOrderedList (ds1++ds2)) d
docAppend (DocDefList ds1) (DocDefList ds2)
= DocDefList (ds1++ds2)
docAppend (DocDefList ds1) (DocAppend (DocDefList ds2) d)
= DocAppend (DocDefList (ds1++ds2)) d
docAppend DocEmpty d = d
docAppend d DocEmpty = d
docAppend d1 d2
= DocAppend d1 d2
-- again to make parsing easier - we spot a paragraph whose only item
-- is a DocMonospaced and make it into a DocCodeBlock
docParagraph :: Doc id -> Doc id
docParagraph (DocMonospaced p)
= DocCodeBlock (docCodeBlock p)
docParagraph (DocAppend (DocString s1) (DocMonospaced p))
| all isSpace s1
= DocCodeBlock (docCodeBlock p)
docParagraph (DocAppend (DocString s1)
(DocAppend (DocMonospaced p) (DocString s2)))
| all isSpace s1 && all isSpace s2
= DocCodeBlock (docCodeBlock p)
docParagraph (DocAppend (DocMonospaced p) (DocString s2))
| all isSpace s2
= DocCodeBlock (docCodeBlock p)
docParagraph p
= DocParagraph p
-- Drop trailing whitespace from @..@ code blocks. Otherwise this:
--
-- -- @
-- -- foo
-- -- @
--
-- turns into (DocCodeBlock "\nfoo\n ") which when rendered in HTML
-- gives an extra vertical space after the code block. The single space
-- on the final line seems to trigger the extra vertical space.
--
docCodeBlock :: Doc id -> Doc id
docCodeBlock (DocString s)
= DocString (reverse $ dropWhile (`elem` " \t") $ reverse s)
docCodeBlock (DocAppend l r)
= DocAppend l (docCodeBlock r)
docCodeBlock d = d
-- | This is a hack that joins neighbouring 'DocString's into a single one.
-- This is done to ease up the testing and doesn't change the final result
-- as this would be done later anyway.
combineStringNodes :: Doc id -> Doc id
combineStringNodes (DocAppend (DocString x) (DocString y)) = DocString (x ++ y)
combineStringNodes (DocAppend (DocString x) (DocAppend (DocString y) z)) =
tryjoin (DocAppend (DocString (x ++ y)) (combineStringNodes z))
combineStringNodes (DocAppend x y) = tryjoin (DocAppend (combineStringNodes x) (combineStringNodes y))
combineStringNodes (DocParagraph x) = DocParagraph (combineStringNodes x)
combineStringNodes (DocWarning x) = DocWarning (combineStringNodes x)
combineStringNodes (DocEmphasis x) = DocEmphasis (combineStringNodes x)
combineStringNodes (DocMonospaced x) = DocMonospaced (combineStringNodes x)
combineStringNodes (DocUnorderedList xs) = DocUnorderedList (map combineStringNodes xs)
combineStringNodes (DocOrderedList x) = DocOrderedList (map combineStringNodes x)
combineStringNodes (DocDefList xs) = DocDefList (map (combineStringNodes *** combineStringNodes) xs)
combineStringNodes (DocCodeBlock x) = DocCodeBlock (combineStringNodes x)
combineStringNodes x = x
tryjoin :: Doc id -> Doc id
tryjoin (DocAppend (DocString x) (DocString y)) = DocString (x ++ y)
tryjoin (DocAppend (DocString x) (DocAppend (DocString y) z)) = DocAppend (DocString (x ++ y)) z
tryjoin (DocAppend (DocAppend x (DocString y)) (DocString z))
= tryjoin (DocAppend (combineStringNodes x) (DocString $ y ++ z))
tryjoin x = x
|
