blob: 18555cfb55226cb2756d331dd5ca87823c7e1a1f (
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
|
module Haddock.Doc (
docAppend,
docParagraph,
combineStringNodes
) where
import Haddock.Types
import Data.Char (isSpace)
import Control.Arrow ((***))
-- 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 x = x
|
