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
140
141
142
143
144
145
146
147
148
149
150
|
--------------------------------------------------------------------
-- |
-- Module : Text.XML.Light.Output
-- Copyright : (c) Galois, Inc. 2007
-- License : BSD3
--
-- Maintainer: Iavor S. Diatchki <diatchki@galois.com>
-- Stability : provisional
-- Portability:
--
-- Output handling for the lightweight XML lib.
--
module Text.XML.Light.Output
( showTopElement, showContent, showElement, showCData, showQName, showAttr
, ppTopElement, ppContent, ppElement
, tagEnd, xml_header
) where
import Text.XML.Light.Types
import Data.Char
import Data.List ( isPrefixOf )
-- | The XML 1.0 header
xml_header :: String
xml_header = "<?xml version='1.0' ?>"
-- | Pretty printing renders XML documents faithfully,
-- with the exception that whitespace may be added\/removed
-- in non-verbatim character data.
ppTopElement :: Element -> String
ppTopElement e = unlines [xml_header,ppElement e]
-- | Pretty printing elements
ppElement :: Element -> String
ppElement e = ppElementS "" e ""
-- | Pretty printing content
ppContent :: Content -> String
ppContent x = ppContentS "" x ""
-- | Pretty printing content using ShowS
ppContentS :: String -> Content -> ShowS
ppContentS i x xs = case x of
Elem e -> ppElementS i e xs
Text c -> ppCData i c xs
CRef r -> showCRefS r xs
ppElementS :: String -> Element -> ShowS
ppElementS i e xs = i ++ (tagStart (elName e) (elAttribs e) $
case elContent e of
[]
| not ("?xml" `isPrefixOf` (qName $ elName e)) -> " />" ++ xs
| otherwise -> " ?>" ++ xs
[Text t] -> ">" ++ ppCData "" t (tagEnd (elName e) xs)
cs -> ">\n" ++ foldr ppSub (i ++ tagEnd (elName e) xs) cs
where ppSub e1 = ppContentS (" " ++ i) e1 . showChar '\n'
)
ppCData :: String -> CData -> ShowS
ppCData i c xs = i ++ if (cdVerbatim c /= CDataText )
then showCDataS c xs
else foldr cons xs (showCData c)
where cons :: Char -> String -> String
cons '\n' ys = "\n" ++ i ++ ys
cons y ys = y : ys
--------------------------------------------------------------------------------
-- | Adds the <?xml?> header.
showTopElement :: Element -> String
showTopElement c = xml_header ++ showElement c
showContent :: Content -> String
showContent c = showContentS c ""
showElement :: Element -> String
showElement c = showElementS c ""
showCData :: CData -> String
showCData c = showCDataS c ""
-- Note: crefs should not contain '&', ';', etc.
showCRefS :: String -> ShowS
showCRefS r xs = '&' : r ++ ';' : xs
-- | Good for transmition (no extra white space etc.) but less readable.
showContentS :: Content -> ShowS
showContentS (Elem e) = showElementS e
showContentS (Text cs) = showCDataS cs
showContentS (CRef cs) = showCRefS cs
-- | Good for transmition (no extra white space etc.) but less readable.
showElementS :: Element -> ShowS
showElementS e xs =
tagStart (elName e) (elAttribs e)
$ case elContent e of
[] -> " />" ++ xs
ch -> '>' : foldr showContentS (tagEnd (elName e) xs) ch
-- | Convert a text element to characters.
showCDataS :: CData -> ShowS
showCDataS cd =
case cdVerbatim cd of
CDataText -> escStr (cdData cd)
CDataVerbatim -> showString "<![CDATA[" . escCData (cdData cd) . showString "]]>"
CDataRaw -> \ xs -> cdData cd ++ xs
--------------------------------------------------------------------------------
escCData :: String -> ShowS
escCData (']' : ']' : '>' : cs) = showString "]]]]><![CDATA[>" . escCData cs
escCData (c : cs) = showChar c . escCData cs
escCData [] = id
escChar :: Char -> ShowS
escChar c = case c of
'<' -> showString "<"
'>' -> showString ">"
'&' -> showString "&"
'"' -> showString """
'\'' -> showString "'"
-- XXX: Is this really wortherd?
-- We could deal with these issues when we convert characters to bytes.
_ | (oc <= 0x7f && isPrint c) || c == '\n' || c == '\r' -> showChar c
| otherwise -> showString "&#" . shows oc . showChar ';'
where oc = ord c
escStr :: String -> ShowS
escStr cs rs = foldr escChar rs cs
tagEnd :: QName -> ShowS
tagEnd qn rs = '<':'/':showQName qn ++ '>':rs
tagStart :: QName -> [Attr] -> ShowS
tagStart qn as rs = '<':showQName qn ++ as_str ++ rs
where as_str = if null as then "" else ' ' : unwords (map showAttr as)
showAttr :: Attr -> String
showAttr (Attr qn v) = showQName qn ++ '=' : '"' : escStr v "\""
showQName :: QName -> String
showQName q = pre ++ qName q
where pre = case qPrefix q of
Nothing -> ""
Just p -> p ++ ":"
|
