summaryrefslogtreecommitdiff
path: root/Network/XmlRpc/Pretty.hs
blob: 3f188e01fde27b27cb940d3276275d596c6af470 (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
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving #-}

-- | This is a fast non-pretty-printer for turning the internal representation
--   of generic structured XML documents into Lazy ByteStrings.
--   Like in Text.Xml.HaXml.Pretty, there is one pp function for each type in
--   Text.Xml.HaXml.Types, so you can pretty-print as much or as little
--   of the document as you wish.

module Network.XmlRpc.Pretty (document, content, element, 
                              doctypedecl, prolog, cp) where

import Prelude hiding (maybe, elem, concat, null, head)
import qualified Prelude as P
import Data.ByteString.Lazy.Char8 (ByteString(), elem, empty)
import qualified Data.ByteString.Lazy.UTF8 as BU
import Text.XML.HaXml.Types
import Blaze.ByteString.Builder (Builder, fromLazyByteString, toLazyByteString)
import Blaze.ByteString.Builder.Char.Utf8 (fromString)
import Data.Maybe (isNothing)
import Data.Monoid (Monoid, mempty, mconcat, mappend)
import qualified GHC.Exts as Ext

-- |A 'Builder' with a recognizable empty value.
newtype MBuilder = MBuilder { unMB :: Maybe Builder } deriving Monoid

-- |'Maybe' eliminator specialized for 'MBuilder'.
maybe :: (t -> MBuilder) -> Maybe t -> MBuilder
maybe _ Nothing = mempty
maybe f (Just x) = f x

-- |Nullity predicate for 'MBuilder'.
null :: MBuilder -> Bool
null = isNothing . unMB

-- |Helper for injecting 'ByteString's into 'MBuilder'.
fromLBS :: ByteString -> MBuilder
fromLBS = MBuilder . Just . fromLazyByteString

-- Helper needed when using Data.Binary.Builder.
-- fromString :: String -> Builder
-- fromString = fromLazyByteString . BU.fromString

-- |Support for the OverloadedStrings extension to improve templating
-- syntax.
instance Ext.IsString MBuilder where
  fromString "" = mempty
  fromString s = MBuilder . Just . fromString $ s

-- A simple implementation of the pretty-printing combinator interface,
-- but for plain ByteStrings:
infixr 6 <>
infixr 6 <+>
infixr 5 $$

-- |Beside.
(<>) :: MBuilder -> MBuilder -> MBuilder
(<>) = mappend

-- |Concatenate two 'MBuilder's with a single space in between
-- them. If either of the component 'MBuilder's is empty, then the
-- other is returned without any additional space.
(<+>) :: MBuilder -> MBuilder -> MBuilder
(<+>) b1 b2
  | null b2 = b1
  | null b1 = b2
  | otherwise = b1 <> " " <> b2

-- |Concatenate two 'MBuilder's with a single newline in between
-- them. If either of the component 'MBuilder's is empty, then the
-- other is returned without any additional newline.
($$) :: MBuilder -> MBuilder -> MBuilder
($$) b1 b2 
  | null b2 = b1
  | null b1 = b2
  | otherwise =  b1 <> "\n" <> b2

-- |Concatenate a list of 'MBuilder's with a given 'MBuilder' inserted
-- between each non-empty element of the list.
intercalate :: MBuilder -> [MBuilder] -> MBuilder
intercalate sep = aux . filter (not . null)
  where aux []     = mempty
        aux (x:xs) = x <> mconcat (map (sep <>) xs)

-- |List version of '<+>'.
hsep :: [MBuilder] -> MBuilder             
hsep = intercalate " "

-- |List version of '$$'.
vcat :: [MBuilder] -> MBuilder
vcat = intercalate "\n"

hcatMap :: (a -> MBuilder) -> [a] -> MBuilder
hcatMap = (mconcat .) . map

vcatMap :: (a -> MBuilder) -> [a] -> MBuilder
vcatMap = (vcat .) . map

-- |``Paragraph fill'' version of 'sep'.
fsep :: [MBuilder] -> MBuilder     
fsep = hsep

-- |Bracket an 'MBuilder' with parentheses.
parens :: MBuilder -> MBuilder
parens p = "(" <> p <> ")"

text :: String -> MBuilder
text = MBuilder . Just . fromString

name :: QName -> MBuilder
name = MBuilder . Just . fromString . unQ
  where unQ (QN (Namespace prefix uri) n) = prefix++":"++n
        unQ (N n) = n

----
-- Now for the XML pretty-printing interface.
-- (Basically copied direct from Text.XML.HaXml.Pretty).

-- |Render a 'Document' to a 'ByteString'.
document    :: Document i  -> ByteString
content     :: Content i   -> ByteString
element     :: Element i   -> ByteString
doctypedecl :: DocTypeDecl -> ByteString
prolog      :: Prolog      -> ByteString
cp          :: CP          -> ByteString

-- Builder variants of exported functions.
documentB    :: Document i  -> MBuilder
contentB     :: Content i   -> MBuilder
elementB     :: Element i   -> MBuilder
doctypedeclB :: DocTypeDecl -> MBuilder
prologB      :: Prolog      -> MBuilder
cpB          :: CP          -> MBuilder

xmldecl    :: XMLDecl    -> MBuilder
misc       :: Misc       -> MBuilder
sddecl     :: Bool       -> MBuilder
markupdecl :: MarkupDecl -> MBuilder
attribute  :: Attribute  -> MBuilder

-- |Run an 'MBuilder' to generate a 'ByteString'.
runMBuilder :: MBuilder -> ByteString
runMBuilder = aux . unMB
  where aux Nothing = empty
        aux (Just b) = toLazyByteString b

document    = runMBuilder . documentB
content     = runMBuilder . contentB
element     = runMBuilder . elementB
doctypedecl = runMBuilder . doctypedeclB
prolog      = runMBuilder . prologB
cp          = runMBuilder . cpB

documentB (Document p _ e m) = prologB p $$ elementB e $$ vcatMap misc m

prologB (Prolog x m1 dtd m2) = maybe xmldecl x $$
                               vcatMap misc m1 $$
                               maybe doctypedeclB dtd $$
                               vcatMap misc m2

xmldecl (XMLDecl v e sd)    = "<?xml version='" <> text v <> "'" <+>
                              maybe encodingdecl e <+>
                              maybe sddecl sd <+> "?>"

misc (Comment s)            = "<!--" <+> text s <+> "-->"
misc (PI (n,s))             = "<?" <> text n <+> text s <+> "?>"

sddecl sd   | sd            = "standalone='yes'"
            | otherwise     = "standalone='no'"

doctypedeclB (DTD n eid ds)  = if P.null ds then hd <> ">"
                               else hd <+> " [" $$ vcatMap markupdecl ds $$ "]>"
  where hd = "<!DOCTYPE" <+> name n <+> maybe externalid eid

markupdecl (Element e)      = elementdecl e
markupdecl (AttList a)      = attlistdecl a
markupdecl (Entity e)       = entitydecl e
markupdecl (Notation n)     = notationdecl n
markupdecl (MarkupMisc m)   = misc m

elementB (Elem n as []) = "<" <> (name n <+> fsep (map attribute as)) <> "/>"
elementB (Elem n as cs) 
  | isText (P.head cs)  = "<" <> (name n <+> fsep (map attribute as)) <> ">" <>
                          hcatMap contentB cs <> "</" <> name n <> ">"
  | otherwise           = "<" <> (name n <+> fsep (map attribute as)) <> ">" <>
                          hcatMap contentB cs <> "</" <> name n <> ">"

isText :: Content t -> Bool
isText (CString _ _ _) = True
isText (CRef _ _)      = True
isText _               = False

attribute (n,v) = name n <> "=" <> attvalue v

contentB (CElem e _)         = elementB e
contentB (CString False s _) = chardata s
contentB (CString True s _)  = cdsect s
contentB (CRef r _)          = reference r
contentB (CMisc m _)         = misc m

elementdecl :: ElementDecl -> MBuilder
elementdecl (ElementDecl n cs) = "<!ELEMENT" <+> name n <+>
                                 contentspec cs <> ">"

contentspec :: ContentSpec -> MBuilder
contentspec EMPTY           = "EMPTY"
contentspec ANY             = "ANY"
contentspec (Mixed m)       = mixed m
contentspec (ContentSpec c) = cpB c

cpB (TagName n m) = name n <> modifier m
cpB (Choice cs m) = parens (intercalate "|" (map cpB cs)) <> modifier m
cpB (Seq cs m)    = parens (intercalate "," (map cpB cs)) <> modifier m

modifier :: Modifier -> MBuilder
modifier None  = mempty
modifier Query = "?"
modifier Star  = "*"
modifier Plus  = "+"

mixed :: Mixed -> MBuilder
mixed  PCDATA         = "(#PCDATA)"
mixed (PCDATAplus ns) = "(#PCDATA |" <+> intercalate "|" (map name ns) <> ")*"

attlistdecl :: AttListDecl -> MBuilder
attlistdecl (AttListDecl n ds) = "<!ATTLIST" <+> name n <+> 
                                 fsep (map attdef ds) <> ">"

attdef :: AttDef -> MBuilder
attdef (AttDef n t d)          = name n <+> atttype t <+> defaultdecl d

atttype :: AttType -> MBuilder
atttype  StringType            = "CDATA"
atttype (TokenizedType t)      = tokenizedtype t
atttype (EnumeratedType t)     = enumeratedtype t

tokenizedtype :: TokenizedType -> MBuilder
tokenizedtype ID               = "ID"
tokenizedtype IDREF            = "IDREF"
tokenizedtype IDREFS           = "IDREFS"
tokenizedtype ENTITY           = "ENTITY"
tokenizedtype ENTITIES         = "ENTITIES"
tokenizedtype NMTOKEN          = "NMTOKEN"
tokenizedtype NMTOKENS         = "NMTOKENS"

enumeratedtype :: EnumeratedType -> MBuilder
enumeratedtype (NotationType n) = notationtype n
enumeratedtype (Enumeration e)  = enumeration e

notationtype :: [[Char]] -> MBuilder
notationtype ns                = "NOTATION" <+>
                                 parens (intercalate "|" (map text ns))

enumeration :: [[Char]] -> MBuilder
enumeration ns                 = parens (intercalate "|" (map nmtoken ns))

defaultdecl :: DefaultDecl -> MBuilder
defaultdecl  REQUIRED          = "#REQUIRED"
defaultdecl  IMPLIED           = "#IMPLIED"
defaultdecl (DefaultTo a f)    = maybe (const "#FIXED") f <+> attvalue a

reference :: Reference -> MBuilder
reference (RefEntity er)       = entityref er
reference (RefChar cr)         = charref cr

entityref :: [Char] -> MBuilder
entityref n                    = "&" <> text n <> ";"

charref :: (Show a) => a -> MBuilder
charref c                      = "&#" <> text (show c) <> ";"

entitydecl :: EntityDecl -> MBuilder
entitydecl (EntityGEDecl d)    = gedecl d
entitydecl (EntityPEDecl d)    = pedecl d

gedecl :: GEDecl -> MBuilder
gedecl (GEDecl n ed)           = "<!ENTITY" <+> text n <+> entitydef ed <> ">"

pedecl :: PEDecl -> MBuilder
pedecl (PEDecl n pd)           = "<!ENTITY %" <> text n <+> pedef pd <> ">"

entitydef :: EntityDef -> MBuilder
entitydef (DefEntityValue ew)  = entityvalue ew
entitydef (DefExternalID i nd) = externalid i <+> maybe ndatadecl nd

pedef :: PEDef -> MBuilder
pedef (PEDefEntityValue ew)    = entityvalue ew
pedef (PEDefExternalID eid)    = externalid eid

externalid :: ExternalID -> MBuilder
externalid (SYSTEM sl)         = "SYSTEM" <+> systemliteral sl
externalid (PUBLIC i sl)       = "PUBLIC" <+> pubidliteral i <+> systemliteral sl

ndatadecl :: NDataDecl -> MBuilder
ndatadecl (NDATA n)            = "NDATA" <+> text n

notationdecl :: NotationDecl -> MBuilder
notationdecl (NOTATION n e)    = "<!NOTATION" <+> text n <+>
                                 either externalid publicid e <> ">"

publicid :: PublicID -> MBuilder
publicid (PUBLICID p)          = "PUBLICID" <+> pubidliteral p

encodingdecl :: EncodingDecl -> MBuilder
encodingdecl (EncodingDecl s)  = "encoding='" <> text s <> "'"

nmtoken :: [Char] -> MBuilder
nmtoken s                      = text s

attvalue :: AttValue -> MBuilder
attvalue (AttValue esr)        = "\"" <> hcatMap attVal esr <> "\""
  where attVal = either text reference

entityvalue :: EntityValue -> MBuilder
entityvalue (EntityValue evs)
  | containsDoubleQuote evs    = "'"  <> hcatMap ev evs <> "'"
  | otherwise                  = "\"" <> hcatMap ev evs <> "\""

ev :: EV -> MBuilder
ev (EVString s)                = text s
ev (EVRef r)                   = reference r

pubidliteral :: PubidLiteral -> MBuilder
pubidliteral (PubidLiteral s)
    | '"' `elem` s' = "'" <> fromLBS s' <> "'"
    | otherwise     = "\"" <> fromLBS s' <> "\""
    where s' = BU.fromString s

systemliteral :: SystemLiteral -> MBuilder
systemliteral (SystemLiteral s)
    | '"' `elem` s' = "'" <> fromLBS s' <> "'"
    | otherwise     = "\"" <> fromLBS s' <> "\""
    where s' = BU.fromString s

chardata, cdsect :: [Char] -> MBuilder
chardata s                     = {-if all isSpace s then empty else-} text s
cdsect c                       = "<![CDATA[" <> chardata c <> "]]>"

containsDoubleQuote :: [EV] -> Bool
containsDoubleQuote evs = any csq evs
    where csq (EVString s) = '"' `elem` BU.fromString s
          csq _            = False