0c6dd105b7
since there is currently no debian package. Removed dependency on xml library. Added license to debian/copyright. git-svn-id: https://pandoc.googlecode.com/svn/trunk@1351 788f1e2b-df1e-0410-8736-df70ead52e1b
150 lines
4.8 KiB
Haskell
150 lines
4.8 KiB
Haskell
--------------------------------------------------------------------
|
|
-- |
|
|
-- 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 ++ ":"
|
|
|
|
|
|
|