GF/src is now for 2.9, and the new sources are in src-3.0 - keep it this way until the release of GF 3

1 files changed, 57 insertions, 0 deletions

diff --git a/src-3.0/GF/Data/XML.hs b/src-3.0/GF/Data/XML.hs
new file mode 100644
index 000000000..a1807adcc
--- /dev/null
+++ b/src-3.0/GF/Data/XML.hs
@@ -0,0 +1,57 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : XML
+-- Maintainer  : BB
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- Utilities for creating XML documents.
+-----------------------------------------------------------------------------
+
+module GF.Data.XML (XML(..), Attr, comments, showXMLDoc, showsXMLDoc, showsXML, bottomUpXML) where
+
+import GF.Data.Utilities
+
+data XML = Data String | CData String | Tag String [Attr] [XML] | ETag String [Attr] | Comment String | Empty
+ deriving (Ord,Eq,Show)
+
+type Attr = (String,String)
+
+comments :: [String] -> [XML]
+comments = map Comment
+
+showXMLDoc :: XML -> String
+showXMLDoc xml = showsXMLDoc xml ""
+
+showsXMLDoc :: XML -> ShowS
+showsXMLDoc xml = showString header . showsXML xml 
+  where header = "<?xml version=\"1.0\" encoding=\"UTF-8\" ?>"
+
+showsXML :: XML -> ShowS
+showsXML (Data s) = showString s
+showsXML (CData s) = showString "<![CDATA[" . showString s .showString "]]>"
+showsXML (ETag t as) = showChar '<' . showString t . showsAttrs as . showString "/>"
+showsXML (Tag t as cs) = 
+    showChar '<' . showString t . showsAttrs as . showChar '>' 
+		 . concatS (map showsXML cs) . showString "</" . showString t . showChar '>'
+showsXML (Comment c) = showString "<!-- " . showString c . showString " -->"
+showsXML (Empty) = id
+
+showsAttrs :: [Attr] -> ShowS
+showsAttrs = concatS . map (showChar ' ' .) . map showsAttr
+
+showsAttr :: Attr -> ShowS
+showsAttr (n,v) = showString n . showString "=\"" . showString (escape v) . showString "\""
+
+escape :: String -> String
+escape = concatMap escChar
+  where
+  escChar '<'  = "&lt;"
+  escChar '>'  = "&gt;"
+  escChar '&'  = "&amp;"
+  escChar '"'  = "&quot;"
+  escChar c    = [c]
+
+bottomUpXML :: (XML -> XML) -> XML -> XML
+bottomUpXML f (Tag n attrs cs) = f (Tag n attrs (map (bottomUpXML f) cs))
+bottomUpXML f x = f x