diff options
Diffstat (limited to 'Text/XML/Light/Output.hs')
| -rw-r--r-- | Text/XML/Light/Output.hs | 150 |
1 files changed, 150 insertions, 0 deletions
diff --git a/Text/XML/Light/Output.hs b/Text/XML/Light/Output.hs new file mode 100644 index 000000000..65d1bb1af --- /dev/null +++ b/Text/XML/Light/Output.hs @@ -0,0 +1,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 ++ ":" + + + |