blob: 0e3bd0f9876371f5e2f463fd4464175038f19770 (
plain)
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
128
129
130
131
132
133
134
135
136
137
138
139
|
{-# LANGUAGE OverloadedStrings #-}
{- |
Module : Text.Pandoc.Writers.Shared
Copyright : Copyright (C) 2021 John MacFarlane
License : GNU GPL, version 2 or above
Maintainer : John MacFarlane <jgm@berkeley.edu>
Stability : alpha
Portability : portable
Render blaze-html Html to DocLayout document (so it can be wrapped).
-}
module Text.Pandoc.Writers.Blaze ( layoutMarkup )
where
import Text.Blaze
import qualified Data.ByteString as S
import Data.List (isInfixOf)
import Data.Text.Encoding (decodeUtf8)
import qualified Data.Text as T
import Data.Text (Text)
import Text.DocLayout hiding (Text, Empty)
import Text.Blaze.Internal (ChoiceString(..), getText, MarkupM(..))
layoutMarkup :: Markup -> Doc T.Text
layoutMarkup = go True mempty
where
go :: Bool -> Doc T.Text -> MarkupM b -> Doc T.Text
go wrap attrs (Parent _ open close content) =
let open' = getText open
in literal open'
<> attrs
<> char '>'
<> (if allowsWrap open'
then go wrap mempty content
else flush $ go False mempty content)
<> literal (getText close)
go wrap attrs (CustomParent tag content) =
char '<'
<> fromChoiceString wrap tag
<> attrs
<> char '>'
<> go wrap mempty content
<> literal "</"
<> fromChoiceString wrap tag
<> char '>'
go _wrap attrs (Leaf _ begin end _) =
literal (getText begin)
<> attrs
<> literal (getText end)
go wrap attrs (CustomLeaf tag close _) =
char '<'
<> fromChoiceString wrap tag
<> attrs
<> (if close then literal " />" else char '>')
go wrap attrs (AddAttribute rawkey _ value h) =
go wrap
(space' wrap
<> literal (getText rawkey)
<> char '='
<> doubleQuotes (fromChoiceString wrap value)
<> attrs) h
go wrap attrs (AddCustomAttribute key value h) =
go wrap
(space' wrap
<> fromChoiceString wrap key
<> char '='
<> doubleQuotes (fromChoiceString wrap value)
<> attrs) h
go wrap _ (Content content _) = fromChoiceString wrap content
go wrap _ (Comment comment _) =
literal "<!--"
<> space' wrap
<> fromChoiceString wrap comment
<> space' wrap
<> "-->"
go wrap attrs (Append h1 h2) = go wrap attrs h1 <> go wrap attrs h2
go _ _ (Empty _) = mempty
space' wrap = if wrap then space else char ' '
allowsWrap :: T.Text -> Bool
allowsWrap t =
not (t == "<pre" || t == "<style" || t == "<script" || t == "<textarea")
fromChoiceString :: Bool -- ^ Allow wrapping
-> ChoiceString -- ^ String to render
-> Doc Text -- ^ Resulting builder
fromChoiceString wrap (Static s) = withWrap wrap $ getText s
fromChoiceString wrap (String s) = withWrap wrap $
escapeMarkupEntities $ T.pack s
fromChoiceString wrap (Text s) = withWrap wrap $ escapeMarkupEntities s
fromChoiceString wrap (ByteString s) = withWrap wrap $ decodeUtf8 s
fromChoiceString _wrap (PreEscaped x) = -- don't wrap!
case x of
String s -> literal $ T.pack s
Text s -> literal s
s -> fromChoiceString False s
fromChoiceString wrap (External x) = case x of
-- Check that the sequence "</" is *not* in the external data.
String s -> if "</" `isInfixOf` s then mempty else withWrap wrap (T.pack s)
Text s -> if "</" `T.isInfixOf` s then mempty else withWrap wrap s
ByteString s -> if "</" `S.isInfixOf` s then mempty else withWrap wrap (decodeUtf8 s)
s -> fromChoiceString wrap s
fromChoiceString wrap (AppendChoiceString x y) =
fromChoiceString wrap x <> fromChoiceString wrap y
fromChoiceString _ EmptyChoiceString = mempty
withWrap :: Bool -> Text -> Doc Text
withWrap wrap
| wrap = mconcat . toChunks
| otherwise = literal
toChunks :: Text -> [Doc Text]
toChunks = map toDoc . T.groupBy sameStatus
where
toDoc t =
if T.any (== ' ') t
then space
else if T.any (== '\n') t
then cr
else literal t
sameStatus c d =
(c == ' ' && d == ' ') ||
(c == '\n' && d == '\n') ||
(c /= ' ' && d /= ' ' && c /= '\n' && d /= '\n')
-- | Escape predefined XML entities in a text value
--
escapeMarkupEntities :: Text -- ^ Text to escape
-> Text -- ^ Resulting Doc
escapeMarkupEntities = T.concatMap escape
where
escape :: Char -> Text
escape '<' = "<"
escape '>' = ">"
escape '&' = "&"
escape '"' = """
escape '\'' = "'"
escape x = T.singleton x
|
