@@ -1,5 +1,4 @@
1{-# LANGUAGE FlexibleInstances #-}
1{-# LANGUAGE FlexibleInstances #-}
2−{-# LANGUAGE DeriveDataTypeable #-}
3{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
5 Module : Text.Pandoc.XML.Light
4 Module : Text.Pandoc.XML.Light
@@ -31,59 +30,9 @@ better performance and accuracy without much change in the
31code that used xml-light.
30code that used xml-light.
33module Text.Pandoc.XML.Light
32module Text.Pandoc.XML.Light
34− ( -- * Basic types, duplicating those from xml-light but with Text
33+ ( module Text.Pandoc.XML.Light.Types
35− -- instead of String
34+ , module Text.Pandoc.XML.Light.Proc
36− Line
35+ , module Text.Pandoc.XML.Light.Output
48− -- * Conversion functions from xml-light types
54− -- * Replacement for xml-light's Text.XML.Proc
75− -- * Replacement for xml-light's Text.XML.Output
87 -- * Replacement for xml-light's Text.XML.Input
36 -- * Replacement for xml-light's Text.XML.Input
88 , parseXMLElement
37 , parseXMLElement
89 , parseXMLContents
38 , parseXMLContents
@@ -92,16 +41,13 @@ module Text.Pandoc.XML.Light
92import qualified Control.Exception as E
41import qualified Control.Exception as E
93import qualified Text.XML as Conduit
42import qualified Text.XML as Conduit
94import Text.XML.Unresolved (InvalidEventStream(..))
43import Text.XML.Unresolved (InvalidEventStream(..))
95−import Data.Text (Text)
96import qualified Data.Text as T
44import qualified Data.Text as T
97import qualified Data.Text.Lazy as TL
45import qualified Data.Text.Lazy as TL
98−import Data.Text.Lazy.Builder (Builder, singleton, fromText, toLazyText)
99import qualified Data.Map as M
46import qualified Data.Map as M
100−import Data.Data (Data)
47+import Data.Maybe (mapMaybe)
101−import Data.Typeable (Typeable)
48+import Text.Pandoc.XML.Light.Types
102−import Data.Maybe (mapMaybe, listToMaybe)
49+import Text.Pandoc.XML.Light.Proc
103−import Data.List(find)
50+import Text.Pandoc.XML.Light.Output
104−import qualified Text.XML.Light as XL
106-- Drop in replacement for parseXMLDoc in xml-light.
52-- Drop in replacement for parseXMLDoc in xml-light.
107parseXMLElement :: TL.Text -> Either T.Text Element
53parseXMLElement :: TL.Text -> Either T.Text Element
@@ -141,446 +87,3 @@ nodeToContent (Conduit.NodeContent t) =
141 Just (Text (CData CDataText t Nothing))
87 Just (Text (CData CDataText t Nothing))
142nodeToContent _ = Nothing
88nodeToContent _ = Nothing
144−unqual :: Text -> QName
145−unqual x = QName x Nothing Nothing
147−-- | Add an attribute to an element.
148−add_attr :: Attr -> Element -> Element
149−add_attr a e = add_attrs [a] e
151−-- | Add some attributes to an element.
152−add_attrs :: [Attr] -> Element -> Element
153−add_attrs as e = e { elAttribs = as ++ elAttribs e }
156−-- type definitions lightly modified from xml-light
159−-- | A line is an Integer
163−data Content = Elem Element
166− deriving (Show, Typeable, Data)
169−data Element = Element {
171− elAttribs :: [Attr],
172− elContent :: [Content],
173− elLine :: Maybe Line
174− } deriving (Show, Typeable, Data)
180− } deriving (Eq, Ord, Show, Typeable, Data)
184− cdVerbatim :: CDataKind,
186− cdLine :: Maybe Line
187− } deriving (Show, Typeable, Data)
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 )
195−-- | XML qualified names
199− qPrefix :: Maybe Text
200− } deriving (Show, Typeable, Data)
203−instance Eq QName where
204− q1 == q2 = compare q1 q2 == EQ
206−instance Ord QName where
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
215− node :: QName -> t -> Element
217−instance Node ([Attr],[Content]) where
218− node n (attrs,cont) = Element { elName = n
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])
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])
233−instance Node ([Attr],[Element]) where
234− node n (as,cs) = node n (as,map Elem cs)
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]
241−instance Node ([Attr],[CData]) where
242− node n (as,cs) = node n (as,map Text cs)
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]
249−instance Node ([Attr],Text) where
250− node n (as,t) = node n (as, CData { cdVerbatim = CDataText
252− , cdLine = Nothing })
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)
257−-- | Create node with unqualified name
258−unode :: Node t => Text -> t -> Element
259−unode = node . unqual
262−-- conversion from xml-light
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 }
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 }
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 }
284−fromXLAttr :: XL.Attr -> Attr
285−fromXLAttr (XL.Attr qn s) = Attr (fromXLQName qn) (T.pack s)
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)
293−-- copied from xml-light Text.XML.Proc
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
301−-- | Select only the elements from a list of XML content.
302−onlyElems :: [Content] -> [Element]
303−onlyElems xs = [ x | Elem x <- xs ]
305−-- | Select only the elements from a parent.
306−elChildren :: Element -> [Element]
307−elChildren e = [ x | Elem x <- elContent e ]
309−-- | Select only the text from a list of XML content.
310−onlyText :: [Content] -> [CData]
311−onlyText xs = [ x | Text x <- xs ]
313−-- | Find all immediate children with the given name.
314−findChildren :: QName -> Element -> [Element]
315−findChildren q e = filterChildren ((q ==) . elName) e
317−-- | Filter all immediate children wrt a given predicate.
318−filterChildren :: (Element -> Bool) -> Element -> [Element]
319−filterChildren p e = filter p (onlyElems (elContent e))
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))
327−-- | Find an immediate child with the given name.
328−findChild :: QName -> Element -> Maybe Element
329−findChild q e = listToMaybe (findChildren q e)
331−-- | Find an immediate child with the given name.
332−filterChild :: (Element -> Bool) -> Element -> Maybe Element
333−filterChild p e = listToMaybe (filterChildren p e)
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)
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)
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)
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)
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
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]
363− | otherwise = concatMap (filterElements p) $ onlyElems $ elContent e
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
371−-- | Lookup the value of an attribute.
372−findAttr :: QName -> Element -> Maybe Text
373−findAttr x e = lookupAttr x (elAttribs e)
375−-- | Lookup attribute name from list.
376−lookupAttr :: QName -> [Attr] -> Maybe Text
377−lookupAttr x = lookupAttrBy (x ==)
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
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)
390−-- duplicates functinos from Text.XML.Output
393−-- | The XML 1.0 header
395−xmlHeader = "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"
398−--------------------------------------------------------------------------------
399−data ConfigPP = ConfigPP
400− { shortEmptyTag :: QName -> Bool
404−-- | Default pretty orinting configuration.
405−-- * Always use abbreviate empty tags.
406−defaultConfigPP :: ConfigPP
407−defaultConfigPP = ConfigPP { shortEmptyTag = const True
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 }
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 }
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
432−--------------------------------------------------------------------------------
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
441−-- | Pretty printing elements
442−ppElement :: Element -> Text
443−ppElement = ppcElement prettyConfigPP
445−-- | Pretty printing content
446−ppContent :: Content -> Text
447−ppContent = ppcContent prettyConfigPP
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]
455−-- | Pretty printing elements
456−ppcElement :: ConfigPP -> Element -> Text
457−ppcElement c = TL.toStrict . toLazyText . ppElementS c mempty
459−-- | Pretty printing content
460−ppcContent :: ConfigPP -> Content -> Text
461−ppcContent c = TL.toStrict . toLazyText . ppContentS c mempty
463−ppcCData :: ConfigPP -> CData -> Text
464−ppcCData c = TL.toStrict . toLazyText . ppCDataS c mempty
466−type Indent = Builder
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
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) <>
484− where (nl,sp) = if prettify c then ("\n"," ") else ("","")
486− where name = elName e
488−ppCDataS :: ConfigPP -> Indent -> CData -> Builder
489−ppCDataS c i t = i <> if cdVerbatim t /= CDataText || not (prettify c)
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
498−--------------------------------------------------------------------------------
500−-- | Adds the <?xml?> header.
501−showTopElement :: Element -> Text
502−showTopElement c = xmlHeader <> showElement c
504−showContent :: Content -> Text
505−showContent = ppcContent defaultConfigPP
507−showElement :: Element -> Text
508−showElement = ppcElement defaultConfigPP
510−showCData :: CData -> Text
511−showCData = ppcCData defaultConfigPP
513−-- Note: crefs should not contain '&', ';', etc.
514−showCRefS :: Text -> Builder
515−showCRefS r = singleton '&' <> fromText r <> singleton ';'
517−-- | Convert a text element to characters.
518−showCDataS :: CData -> Builder
520− case cdVerbatim cd of
521− CDataText -> escStr (cdData cd)
522− CDataVerbatim -> fromText "<![CDATA[" <> escCData (cdData cd) <>
524− CDataRaw -> fromText (cdData cd)
526−--------------------------------------------------------------------------------
527−escCData :: Text -> Builder
529− | "]]>" `T.isPrefixOf` t =
530− fromText "]]]]><![CDATA[>" <> fromText (T.drop 3 t)
532− = case T.uncons t of
534− Just (c,t') -> singleton c <> escCData t'
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 "'"
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 ';'
556−escStr :: Text -> Builder
557−escStr cs = if T.any needsEscape cs
558− then mconcat (map escChar (T.unpack cs))
561− needsEscape '<' = True
562− needsEscape '>' = True
563− needsEscape '&' = True
564− needsEscape '"' = True
565− needsEscape '\'' = True
566− needsEscape _ = False
568−tagEnd :: QName -> Builder
569−tagEnd qn = fromText "</" <> showQName qn <> singleton '>'
571−tagStart :: QName -> [Attr] -> Builder
572−tagStart qn as = singleton '<' <> showQName qn <> as_str
573− where as_str = if null as
575− else mconcat (map showAttr as)
577−showAttr :: Attr -> Builder
578−showAttr (Attr qn v) = singleton ' ' <> showQName qn <>
580− singleton '"' <> escStr v <> singleton '"'
582−showQName :: QName -> Builder
585− Nothing -> fromText (qName q)
586− Just p -> fromText p <> singleton ':' <> fromText (qName q)