@@ -1,5 +1,4 @@
11{-# LANGUAGE FlexibleInstances #-}
2−{-# LANGUAGE DeriveDataTypeable #-}
32{-# LANGUAGE OverloadedStrings #-}
43{- |
54 Module : Text.Pandoc.XML.Light
@@ -31,59 +30,9 @@ better performance and accuracy without much change in the
3130code that used xml-light.
3231-}
3332module Text.Pandoc.XML.Light
34− ( -- * Basic types, duplicating those from xml-light but with Text
35− -- instead of String
36− Line
37− , Content(..)
38− , Element(..)
39− , Attr(..)
40− , CData(..)
41− , CDataKind(..)
42− , QName(..)
43− , Node(..)
44− , unode
45− , unqual
46− , add_attr
47− , add_attrs
48− -- * Conversion functions from xml-light types
49− , fromXLQName
50− , fromXLCData
51− , fromXLElement
52− , fromXLAttr
53− , fromXLContent
54− -- * Replacement for xml-light's Text.XML.Proc
55− , strContent
56− , onlyElems
57− , elChildren
58− , onlyText
59− , findChildren
60− , filterChildren
61− , filterChildrenName
62− , findChild
63− , filterChild
64− , filterChildName
65− , findElement
66− , filterElement
67− , filterElementName
68− , findElements
69− , filterElements
70− , filterElementsName
71− , findAttr
72− , lookupAttr
73− , lookupAttrBy
74− , findAttrBy
75− -- * Replacement for xml-light's Text.XML.Output
76− , ppTopElement
77− , ppElement
78− , ppContent
79− , ppcElement
80− , ppcContent
81− , showTopElement
82− , showElement
83− , showContent
84− , useShortEmptyTags
85− , defaultConfigPP
86− , ConfigPP(..)
33+ ( module Text.Pandoc.XML.Light.Types
34+ , module Text.Pandoc.XML.Light.Proc
35+ , module Text.Pandoc.XML.Light.Output
8736 -- * Replacement for xml-light's Text.XML.Input
8837 , parseXMLElement
8938 , parseXMLContents
@@ -92,16 +41,13 @@ module Text.Pandoc.XML.Light
9241import qualified Control.Exception as E
9342import qualified Text.XML as Conduit
9443import Text.XML.Unresolved (InvalidEventStream(..))
95−import Data.Text (Text)
9644import qualified Data.Text as T
9745import qualified Data.Text.Lazy as TL
98−import Data.Text.Lazy.Builder (Builder, singleton, fromText, toLazyText)
9946import qualified Data.Map as M
100−import Data.Data (Data)
101−import Data.Typeable (Typeable)
102−import Data.Maybe (mapMaybe, listToMaybe)
103−import Data.List(find)
104−import qualified Text.XML.Light as XL
47+import Data.Maybe (mapMaybe)
48+import Text.Pandoc.XML.Light.Types
49+import Text.Pandoc.XML.Light.Proc
50+import Text.Pandoc.XML.Light.Output
10551
10652-- Drop in replacement for parseXMLDoc in xml-light.
10753parseXMLElement :: TL.Text -> Either T.Text Element
@@ -141,446 +87,3 @@ nodeToContent (Conduit.NodeContent t) =
14187 Just (Text (CData CDataText t Nothing))
14288nodeToContent _ = Nothing
14389
144−unqual :: Text -> QName
145−unqual x = QName x Nothing Nothing
146−
147−-- | Add an attribute to an element.
148−add_attr :: Attr -> Element -> Element
149−add_attr a e = add_attrs [a] e
150−
151−-- | Add some attributes to an element.
152−add_attrs :: [Attr] -> Element -> Element
153−add_attrs as e = e { elAttribs = as ++ elAttribs e }
154−
155−--
156−-- type definitions lightly modified from xml-light
157−--
158−
159−-- | A line is an Integer
160−type Line = Integer
161−
162−-- | XML content
163−data Content = Elem Element
164− | Text CData
165− | CRef Text
166− deriving (Show, Typeable, Data)
167−
168−-- | XML elements
169−data Element = Element {
170− elName :: QName,
171− elAttribs :: [Attr],
172− elContent :: [Content],
173− elLine :: Maybe Line
174− } deriving (Show, Typeable, Data)
175−
176−-- | XML attributes
177−data Attr = Attr {
178− attrKey :: QName,
179− attrVal :: Text
180− } deriving (Eq, Ord, Show, Typeable, Data)
181−
182−-- | XML CData
183−data CData = CData {
184− cdVerbatim :: CDataKind,
185− cdData :: Text,
186− cdLine :: Maybe Line
187− } deriving (Show, Typeable, Data)
188−
189−data CDataKind
190− = CDataText -- ^ Ordinary character data; pretty printer escapes &, < etc.
191− | CDataVerbatim -- ^ Unescaped character data; pretty printer embeds it in <![CDATA[..
192− | CDataRaw -- ^ As-is character data; pretty printer passes it along without any escaping or CDATA wrap-up.
193− deriving ( Eq, Show, Typeable, Data )
194−
195−-- | XML qualified names
196−data QName = QName {
197− qName :: Text,
198− qURI :: Maybe Text,
199− qPrefix :: Maybe Text
200− } deriving (Show, Typeable, Data)
201−
202−
203−instance Eq QName where
204− q1 == q2 = compare q1 q2 == EQ
205−
206−instance Ord QName where
207− compare q1 q2 =
208− case compare (qName q1) (qName q2) of
209− EQ -> case (qURI q1, qURI q2) of
210− (Nothing,Nothing) -> compare (qPrefix q1) (qPrefix q2)
211− (u1,u2) -> compare u1 u2
212− x -> x
213−
214−class Node t where
215− node :: QName -> t -> Element
216−
217−instance Node ([Attr],[Content]) where
218− node n (attrs,cont) = Element { elName = n
219− , elAttribs = attrs
220− , elContent = cont
221− , elLine = Nothing
222− }
223−
224−instance Node [Attr] where node n as = node n (as,[]::[Content])
225−instance Node Attr where node n a = node n [a]
226−instance Node () where node n () = node n ([]::[Attr])
227−
228−instance Node [Content] where node n cs = node n ([]::[Attr],cs)
229−instance Node Content where node n c = node n [c]
230−instance Node ([Attr],Content) where node n (as,c) = node n (as,[c])
231−instance Node (Attr,Content) where node n (a,c) = node n ([a],[c])
232−
233−instance Node ([Attr],[Element]) where
234− node n (as,cs) = node n (as,map Elem cs)
235−
236−instance Node ([Attr],Element) where node n (as,c) = node n (as,[c])
237−instance Node (Attr,Element) where node n (a,c) = node n ([a],c)
238−instance Node [Element] where node n es = node n ([]::[Attr],es)
239−instance Node Element where node n e = node n [e]
240−
241−instance Node ([Attr],[CData]) where
242− node n (as,cs) = node n (as,map Text cs)
243−
244−instance Node ([Attr],CData) where node n (as,c) = node n (as,[c])
245−instance Node (Attr,CData) where node n (a,c) = node n ([a],c)
246−instance Node [CData] where node n es = node n ([]::[Attr],es)
247−instance Node CData where node n e = node n [e]
248−
249−instance Node ([Attr],Text) where
250− node n (as,t) = node n (as, CData { cdVerbatim = CDataText
251− , cdData = t
252− , cdLine = Nothing })
253−
254−instance Node (Attr,Text ) where node n (a,t) = node n ([a],t)
255−instance Node Text where node n t = node n ([]::[Attr],t)
256−
257−-- | Create node with unqualified name
258−unode :: Node t => Text -> t -> Element
259−unode = node . unqual
260−
261−--
262−-- conversion from xml-light
263−--
264−
265−fromXLQName :: XL.QName -> QName
266−fromXLQName qn = QName { qName = T.pack $ XL.qName qn
267− , qURI = T.pack <$> XL.qURI qn
268− , qPrefix = T.pack <$> XL.qPrefix qn }
269−
270−fromXLCData :: XL.CData -> CData
271−fromXLCData cd = CData { cdVerbatim = case XL.cdVerbatim cd of
272− XL.CDataText -> CDataText
273− XL.CDataVerbatim -> CDataVerbatim
274− XL.CDataRaw -> CDataRaw
275− , cdData = T.pack $ XL.cdData cd
276− , cdLine = XL.cdLine cd }
277−
278−fromXLElement :: XL.Element -> Element
279−fromXLElement el = Element { elName = fromXLQName $ XL.elName el
280− , elAttribs = map fromXLAttr $ XL.elAttribs el
281− , elContent = map fromXLContent $ XL.elContent el
282− , elLine = XL.elLine el }
283−
284−fromXLAttr :: XL.Attr -> Attr
285−fromXLAttr (XL.Attr qn s) = Attr (fromXLQName qn) (T.pack s)
286−
287−fromXLContent :: XL.Content -> Content
288−fromXLContent (XL.Elem el) = Elem $ fromXLElement el
289−fromXLContent (XL.Text cd) = Text $ fromXLCData cd
290−fromXLContent (XL.CRef s) = CRef (T.pack s)
291−
292−--
293−-- copied from xml-light Text.XML.Proc
294−--
295−
296−-- | Get the text value of an XML element. This function
297−-- ignores non-text elements, and concatenates all text elements.
298−strContent :: Element -> Text
299−strContent = mconcat . map cdData . onlyText . elContent
300−
301−-- | Select only the elements from a list of XML content.
302−onlyElems :: [Content] -> [Element]
303−onlyElems xs = [ x | Elem x <- xs ]
304−
305−-- | Select only the elements from a parent.
306−elChildren :: Element -> [Element]
307−elChildren e = [ x | Elem x <- elContent e ]
308−
309−-- | Select only the text from a list of XML content.
310−onlyText :: [Content] -> [CData]
311−onlyText xs = [ x | Text x <- xs ]
312−
313−-- | Find all immediate children with the given name.
314−findChildren :: QName -> Element -> [Element]
315−findChildren q e = filterChildren ((q ==) . elName) e
316−
317−-- | Filter all immediate children wrt a given predicate.
318−filterChildren :: (Element -> Bool) -> Element -> [Element]
319−filterChildren p e = filter p (onlyElems (elContent e))
320−
321−
322−-- | Filter all immediate children wrt a given predicate over their names.
323−filterChildrenName :: (QName -> Bool) -> Element -> [Element]
324−filterChildrenName p e = filter (p.elName) (onlyElems (elContent e))
325−
326−
327−-- | Find an immediate child with the given name.
328−findChild :: QName -> Element -> Maybe Element
329−findChild q e = listToMaybe (findChildren q e)
330−
331−-- | Find an immediate child with the given name.
332−filterChild :: (Element -> Bool) -> Element -> Maybe Element
333−filterChild p e = listToMaybe (filterChildren p e)
334−
335−-- | Find an immediate child with name matching a predicate.
336−filterChildName :: (QName -> Bool) -> Element -> Maybe Element
337−filterChildName p e = listToMaybe (filterChildrenName p e)
338−
339−-- | Find the left-most occurrence of an element matching given name.
340−findElement :: QName -> Element -> Maybe Element
341−findElement q e = listToMaybe (findElements q e)
342−
343−-- | Filter the left-most occurrence of an element wrt. given predicate.
344−filterElement :: (Element -> Bool) -> Element -> Maybe Element
345−filterElement p e = listToMaybe (filterElements p e)
346−
347−-- | Filter the left-most occurrence of an element wrt. given predicate.
348−filterElementName :: (QName -> Bool) -> Element -> Maybe Element
349−filterElementName p e = listToMaybe (filterElementsName p e)
350−
351−-- | Find all non-nested occurances of an element.
352−-- (i.e., once we have found an element, we do not search
353−-- for more occurances among the element's children).
354−findElements :: QName -> Element -> [Element]
355−findElements qn e = filterElementsName (qn==) e
356−
357−-- | Find all non-nested occurrences of an element wrt. given predicate.
358−-- (i.e., once we have found an element, we do not search
359−-- for more occurances among the element's children).
360−filterElements :: (Element -> Bool) -> Element -> [Element]
361−filterElements p e
362− | p e = [e]
363− | otherwise = concatMap (filterElements p) $ onlyElems $ elContent e
364−
365−-- | Find all non-nested occurences of an element wrt a predicate over element names.
366−-- (i.e., once we have found an element, we do not search
367−-- for more occurances among the element's children).
368−filterElementsName :: (QName -> Bool) -> Element -> [Element]
369−filterElementsName p e = filterElements (p.elName) e
370−
371−-- | Lookup the value of an attribute.
372−findAttr :: QName -> Element -> Maybe Text
373−findAttr x e = lookupAttr x (elAttribs e)
374−
375−-- | Lookup attribute name from list.
376−lookupAttr :: QName -> [Attr] -> Maybe Text
377−lookupAttr x = lookupAttrBy (x ==)
378−
379−-- | Lookup the first attribute whose name satisfies the given predicate.
380−lookupAttrBy :: (QName -> Bool) -> [Attr] -> Maybe Text
381−lookupAttrBy p as = attrVal `fmap` find (p . attrKey) as
382−
383−-- | Lookup the value of the first attribute whose name
384−-- satisfies the given predicate.
385−findAttrBy :: (QName -> Bool) -> Element -> Maybe Text
386−findAttrBy p e = lookupAttrBy p (elAttribs e)
387−
388−
389−--
390−-- duplicates functinos from Text.XML.Output
391−--
392−
393−-- | The XML 1.0 header
394−xmlHeader :: Text
395−xmlHeader = "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"
396−
397−
398−--------------------------------------------------------------------------------
399−data ConfigPP = ConfigPP
400− { shortEmptyTag :: QName -> Bool
401− , prettify :: Bool
402− }
403−
404−-- | Default pretty orinting configuration.
405−-- * Always use abbreviate empty tags.
406−defaultConfigPP :: ConfigPP
407−defaultConfigPP = ConfigPP { shortEmptyTag = const True
408− , prettify = False
409− }
410−
411−-- | The predicate specifies for which empty tags we should use XML's
412−-- abbreviated notation <TAG />. This is useful if we are working with
413−-- some XML-ish standards (such as certain versions of HTML) where some
414−-- empty tags should always be displayed in the <TAG></TAG> form.
415−useShortEmptyTags :: (QName -> Bool) -> ConfigPP -> ConfigPP
416−useShortEmptyTags p c = c { shortEmptyTag = p }
417−
418−
419−-- | Specify if we should use extra white-space to make document more readable.
420−-- WARNING: This adds additional white-space to text elements,
421−-- and so it may change the meaning of the document.
422−useExtraWhiteSpace :: Bool -> ConfigPP -> ConfigPP
423−useExtraWhiteSpace p c = c { prettify = p }
424−
425−-- | A configuration that tries to make things pretty
426−-- (possibly at the cost of changing the semantics a bit
427−-- through adding white space.)
428−prettyConfigPP :: ConfigPP
429−prettyConfigPP = useExtraWhiteSpace True defaultConfigPP
430−
431−
432−--------------------------------------------------------------------------------
433−
434−
435−-- | Pretty printing renders XML documents faithfully,
436−-- with the exception that whitespace may be added\/removed
437−-- in non-verbatim character data.
438−ppTopElement :: Element -> Text
439−ppTopElement = ppcTopElement prettyConfigPP
440−
441−-- | Pretty printing elements
442−ppElement :: Element -> Text
443−ppElement = ppcElement prettyConfigPP
444−
445−-- | Pretty printing content
446−ppContent :: Content -> Text
447−ppContent = ppcContent prettyConfigPP
448−
449−-- | Pretty printing renders XML documents faithfully,
450−-- with the exception that whitespace may be added\/removed
451−-- in non-verbatim character data.
452−ppcTopElement :: ConfigPP -> Element -> Text
453−ppcTopElement c e = T.unlines [xmlHeader,ppcElement c e]
454−
455−-- | Pretty printing elements
456−ppcElement :: ConfigPP -> Element -> Text
457−ppcElement c = TL.toStrict . toLazyText . ppElementS c mempty
458−
459−-- | Pretty printing content
460−ppcContent :: ConfigPP -> Content -> Text
461−ppcContent c = TL.toStrict . toLazyText . ppContentS c mempty
462−
463−ppcCData :: ConfigPP -> CData -> Text
464−ppcCData c = TL.toStrict . toLazyText . ppCDataS c mempty
465−
466−type Indent = Builder
467−
468−-- | Pretty printing content using ShowT
469−ppContentS :: ConfigPP -> Indent -> Content -> Builder
470−ppContentS c i x = case x of
471− Elem e -> ppElementS c i e
472− Text t -> ppCDataS c i t
473− CRef r -> showCRefS r
474−
475−ppElementS :: ConfigPP -> Indent -> Element -> Builder
476−ppElementS c i e = i <> tagStart (elName e) (elAttribs e) <>
477− (case elContent e of
478− [] | "?" `T.isPrefixOf` qName name -> fromText " ?>"
479− | shortEmptyTag c name -> fromText " />"
480− [Text t] -> singleton '>' <> ppCDataS c mempty t <> tagEnd name
481− cs -> singleton '>' <> nl <>
482− mconcat (map ((<> nl) . ppContentS c (sp <> i)) cs) <>
483− i <> tagEnd name
484− where (nl,sp) = if prettify c then ("\n"," ") else ("","")
485− )
486− where name = elName e
487−
488−ppCDataS :: ConfigPP -> Indent -> CData -> Builder
489−ppCDataS c i t = i <> if cdVerbatim t /= CDataText || not (prettify c)
490− then showCDataS t
491− else foldr cons mempty (T.unpack (showCData t))
492− where cons :: Char -> Builder -> Builder
493− cons '\n' ys = singleton '\n' <> i <> ys
494− cons y ys = singleton y <> ys
495−
496−
497−
498−--------------------------------------------------------------------------------
499−
500−-- | Adds the <?xml?> header.
501−showTopElement :: Element -> Text
502−showTopElement c = xmlHeader <> showElement c
503−
504−showContent :: Content -> Text
505−showContent = ppcContent defaultConfigPP
506−
507−showElement :: Element -> Text
508−showElement = ppcElement defaultConfigPP
509−
510−showCData :: CData -> Text
511−showCData = ppcCData defaultConfigPP
512−
513−-- Note: crefs should not contain '&', ';', etc.
514−showCRefS :: Text -> Builder
515−showCRefS r = singleton '&' <> fromText r <> singleton ';'
516−
517−-- | Convert a text element to characters.
518−showCDataS :: CData -> Builder
519−showCDataS cd =
520− case cdVerbatim cd of
521− CDataText -> escStr (cdData cd)
522− CDataVerbatim -> fromText "<![CDATA[" <> escCData (cdData cd) <>
523− fromText "]]>"
524− CDataRaw -> fromText (cdData cd)
525−
526−--------------------------------------------------------------------------------
527−escCData :: Text -> Builder
528−escCData t
529− | "]]>" `T.isPrefixOf` t =
530− fromText "]]]]><![CDATA[>" <> fromText (T.drop 3 t)
531−escCData t
532− = case T.uncons t of
533− Nothing -> mempty
534− Just (c,t') -> singleton c <> escCData t'
535−
536−escChar :: Char -> Builder
537−escChar c = case c of
538− '<' -> fromText "<"
539− '>' -> fromText ">"
540− '&' -> fromText "&"
541− '"' -> fromText """
542− -- we use ' instead of ' because IE apparently has difficulties
543− -- rendering ' in xhtml.
544− -- Reported by Rohan Drape <rohan.drape@gmail.com>.
545− '\'' -> fromText "'"
546− _ -> singleton c
547−
548− {- original xml-light version:
549− -- NOTE: We escape '\r' explicitly because otherwise they get lost
550− -- when parsed back in because of then end-of-line normalization rules.
551− _ | isPrint c || c == '\n' -> singleton c
552− | otherwise -> showText "&#" . showsT oc . singleton ';'
553− where oc = ord c
554− -}
555−
556−escStr :: Text -> Builder
557−escStr cs = if T.any needsEscape cs
558− then mconcat (map escChar (T.unpack cs))
559− else fromText cs
560− where
561− needsEscape '<' = True
562− needsEscape '>' = True
563− needsEscape '&' = True
564− needsEscape '"' = True
565− needsEscape '\'' = True
566− needsEscape _ = False
567−
568−tagEnd :: QName -> Builder
569−tagEnd qn = fromText "</" <> showQName qn <> singleton '>'
570−
571−tagStart :: QName -> [Attr] -> Builder
572−tagStart qn as = singleton '<' <> showQName qn <> as_str
573− where as_str = if null as
574− then mempty
575− else mconcat (map showAttr as)
576−
577−showAttr :: Attr -> Builder
578−showAttr (Attr qn v) = singleton ' ' <> showQName qn <>
579− singleton '=' <>
580− singleton '"' <> escStr v <> singleton '"'
581−
582−showQName :: QName -> Builder
583−showQName q =
584− case qPrefix q of
585− Nothing -> fromText (qName q)
586− Just p -> fromText p <> singleton ':' <> fromText (qName q)