diff --git a/Text/XML/Expat/Format.hs b/Text/XML/Expat/Format.hs --- a/Text/XML/Expat/Format.hs +++ b/Text/XML/Expat/Format.hs @@ -3,17 +3,21 @@ -- Copyright (C) 2009 Stephen Blackheath -- | This module provides functions to format a tree --- structure as UTF-8 encoded XML. +-- structure or SAX stream as UTF-8 encoded XML. {-# LANGUAGE FlexibleContexts #-} module Text.XML.Expat.Format ( + -- * High level formatTree, formatTree', formatNode, formatNode', - putTree, - putNode + -- * Low level + xmlHeader, + treeToSAX, + formatSAX, + formatSAX' ) where import Text.XML.Expat.IO @@ -23,84 +27,104 @@ import Data.ByteString.Internal (c2w, w2c) import qualified Data.Text as T import qualified Data.Text.Encoding as TE -import Data.Binary.Put -import Control.Monad +import Data.Word -- | Format document with Node tag text -> L.ByteString -formatTree node = runPut $ putTree node +formatTree node = xmlHeader `L.append` formatNode node -- | Format document with Node tag text -> B.ByteString -formatTree' node = B.concat $ L.toChunks $ runPut $ putTree node +formatTree' = B.concat . L.toChunks . formatTree -- | Format XML node with no header - lazy variant that returns lazy ByteString. formatNode :: (GenericXMLString tag, GenericXMLString text) => Node tag text -> L.ByteString -formatNode node = runPut $ putNode node +formatNode = formatSAX . treeToSAX -- | Format XML node with no header - strict variant that returns strict ByteString. formatNode' :: (GenericXMLString tag, GenericXMLString text) => Node tag text -> B.ByteString -formatNode' node = B.concat $ L.toChunks $ runPut $ putNode node +formatNode' = B.concat . L.toChunks . formatNode --- | 'Data.Binary.Put.Put' interface for formatting a tree with - Node tag text - -> Put -putTree node = do - putByteString $ pack "\n" - putNode node +xmlHeader :: L.ByteString +xmlHeader = L.pack $ map c2w "\n" --- | 'Data.Binary.Put.Put' interface for formatting a node with no header. -putNode :: (GenericXMLString tag, GenericXMLString text) => - Node tag text - -> Put -putNode (Element name attrs children) = do - putWord8 $ c2w '<' - let putThisTag = putByteString $ gxToByteString name - putThisTag - forM_ attrs $ \(aname, avalue) -> do - putWord8 $ c2w ' ' - putByteString $ gxToByteString aname - putByteString $ pack "=\"" - putXMLText $ gxToByteString avalue - putByteString $ pack "\"" - if null children - then - putByteString $ pack "/>" - else do - putWord8 $ c2w '>' - forM_ children putNode - putByteString $ pack "' - flush -putNode (Text txt) = - putXMLText $ gxToByteString txt +-- | Flatten a tree structure into SAX events. +treeToSAX :: Node tag text -> [SAXEvent tag text] +treeToSAX (Element name atts children) = + StartElement name atts : concatMap treeToSAX children ++ [EndElement name] +treeToSAX (Text txt) = [CharacterData txt] +-- | Format SAX events with no header - lazy variant that returns lazy ByteString. +formatSAX :: (GenericXMLString tag, GenericXMLString text) => + [SAXEvent tag text] + -> L.ByteString +formatSAX = L.fromChunks . putSAX + +-- | Format SAX events with no header - strict variant that returns strict ByteString. +formatSAX' :: (GenericXMLString tag, GenericXMLString text) => + [SAXEvent tag text] + -> B.ByteString +formatSAX' = B.concat . L.toChunks . formatSAX + +-- Do start tag and attributes but omit closing > +startTagHelper :: (GenericXMLString tag, GenericXMLString text) => + tag + -> [(tag, text)] + -> [B.ByteString] +startTagHelper name atts = + B.singleton (c2w '<'): + gxToByteString name: + concatMap ( + \(aname, avalue) -> + B.singleton (c2w ' '): + gxToByteString aname: + pack "=\"": + escapeText (gxToByteString avalue)++ + [B.singleton (c2w '"')] + ) atts + +putSAX :: (GenericXMLString tag, GenericXMLString text) => + [SAXEvent tag text] + -> [B.ByteString] +putSAX (StartElement name attrs:EndElement name2:elts) = + B.concat (startTagHelper name attrs ++ [pack "/>"]):putSAX elts +putSAX (StartElement name attrs:elts) = + B.concat (startTagHelper name attrs ++ [B.singleton (c2w '>')]):putSAX elts +putSAX (EndElement name:elts) = + B.concat [pack "')]:putSAX elts +putSAX (CharacterData txt:elts) = + B.concat (escapeText (gxToByteString txt)):putSAX elts +putSAX [] = [] + pack :: String -> B.ByteString pack = B.pack . map c2w unpack :: L.ByteString -> String unpack = map w2c . L.unpack -putXMLText :: B.ByteString -> Put -putXMLText str | B.null str = return () -putXMLText str = do - case w2c $ B.head str of - '&' -> putByteString $ pack "&" - '<' -> putByteString $ pack "<" - '"' -> putByteString $ pack """ - '\'' -> putByteString $ pack "'" - ch -> putWord8 (c2w ch) - putXMLText $ B.tail str +escapees :: [Word8] +escapees = map c2w "&<\"'" + +escapeText :: B.ByteString -> [B.ByteString] +escapeText str | B.null str = [] +escapeText str = + let (good, bad) = B.span (`notElem` escapees) str + in if B.null good + then case w2c $ B.head str of + '&' -> pack "&":escapeText rem + '<' -> pack "<":escapeText rem + '"' -> pack """:escapeText rem + '\'' -> pack "'":escapeText rem + _ -> error "hexpat: impossible" + else good:escapeText bad + where + rem = B.tail str diff --git a/Text/XML/Expat/Qualified.hs b/Text/XML/Expat/Qualified.hs --- a/Text/XML/Expat/Qualified.hs +++ b/Text/XML/Expat/Qualified.hs @@ -33,7 +33,6 @@ import Control.Monad.Writer import Control.Parallel.Strategies import Data.Monoid -import Data.Binary.Put import qualified Codec.Binary.UTF8.String as U8 -- | A qualified name. diff --git a/Text/XML/Expat/Tree.hs b/Text/XML/Expat/Tree.hs --- a/Text/XML/Expat/Tree.hs +++ b/Text/XML/Expat/Tree.hs @@ -122,7 +122,6 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified Codec.Binary.UTF8.String as U8 -import Data.Binary.Put import Data.Monoid import Data.Typeable import Control.Exception.Extensible as Exc diff --git a/hexpat.cabal b/hexpat.cabal --- a/hexpat.cabal +++ b/hexpat.cabal @@ -1,6 +1,6 @@ -Cabal-Version: >= 1.2 +Cabal-Version: >= 1.4 Name: hexpat -Version: 0.8 +Version: 0.9 Synopsis: wrapper for expat, the fast XML parser Description: Expat () is a stream-oriented XML parser @@ -44,12 +44,11 @@ Library Build-Depends: - base, + base >= 3 && < 5, haskell98, bytestring, mtl >= 1.1.0.0, text >= 0.1, - binary >= 0.4, utf8-string >= 0.3.3, parallel, containers,