hexpat 0.18.3 → 0.19

raw patch · 12 files changed

+1263/−93 lines, 12 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Text/XML/Expat/Annotated.hs +34/−19
• Text/XML/Expat/Extended.hs +432/−0
• Text/XML/Expat/Format.hs +113/−8
• Text/XML/Expat/Internal/DocumentClass.hs +98/−0
• Text/XML/Expat/Internal/IO.hs +229/−30
• Text/XML/Expat/Internal/NodeClass.hs +21/−3
• Text/XML/Expat/SAX.hs +79/−5
• Text/XML/Expat/Tree.hs +25/−14
• hexpat.cabal +16/−8
• test/suite/TestSuite.hs +4/−0
• test/suite/Text/XML/Expat/ParseFormat.hs +204/−0
• test/suite/Text/XML/Expat/UnitTests.hs +8/−6

@@ -43,8 +43,7 @@   parseThrowing,   XMLParseException(..), -  -- * SAX-style parse-  SAXEvent(..),+  -- * Convert from SAX   saxToTree,    -- * Abstraction of string types@@ -111,7 +110,7 @@ -- -- Note that some functions in the @Text.XML.Expat.Cursor@ module need to create -- new nodes through the 'MkElementClass' type class. Normally this can only be done--- if @a@ is a Maybe type (so it can provide the Nothing value for the annotation+-- if @a@ is a Maybe type or () (so it can provide the Nothing value for the annotation -- on newly created nodes).  Or, you can write your own 'MkElementClass' instance. -- Apart from that, there is no requirement for @a@ to be a Maybe type. data NodeG a c tag text =@@ -135,8 +134,12 @@ type Node a tag text = NodeG a [] tag text  instance (Show tag, Show text, Show a) => Show (NodeG a [] tag text) where-    show (Element na at ch an) = "Element "++show na++" "++show at++" "++show ch++" "++show an-    show (Text t) = "Text "++show t+    showsPrec d (Element na at ch an) = showParen (d > 10) $+        ("Element "++) . showsPrec 11 na . (" "++) .+                         showsPrec 11 at . (" "++) .+                         showsPrec 11 ch . (" "++) .+                         showsPrec 11 an+    showsPrec d (Text t) = showParen (d > 10) $ ("Text "++) . showsPrec 11 t  instance (Eq tag, Eq text, Eq a) => Eq (NodeG a [] tag text) where     Element na1 at1 ch1 an1 == Element na2 at2 ch2 an2 =@@ -164,13 +167,20 @@          isText (Text _) = True     isText _        = False-    ++    isCData _ = False+    isProcessingInstruction _ = False+    isComment _ = False+     isNamed _  (Text _) = False     isNamed nm (Element nm' _ _ _) = nm == nm'      getName (Text _)             = mempty     getName (Element name _ _ _) = name +    hasTarget _ _ = False+    getTarget _ = mempty+     getAttributes (Text _)              = []     getAttributes (Element _ attrs _ _) = attrs @@ -207,6 +217,9 @@ instance (Functor c, List c) => MkElementClass (NodeG (Maybe a)) c where     mkElement name attrs children = Element name attrs children Nothing +instance (Functor c, List c) => MkElementClass (NodeG ()) c where+    mkElement name attrs children = Element name attrs children ()+ -- | Convert an annotated tree (/Annotated/ module) into a non-annotated -- tree (/Tree/ module).  DEPRECATED in favour of 'fromElement'. unannotate :: Functor c => NodeG a c tag text -> Tree.NodeG c tag text@@ -214,27 +227,27 @@ unannotate (Element na at ch _) = (Tree.Element na at (fmap unannotate ch)) unannotate (Text t) = Tree.Text t --- | Type alias for a single annotated node with unqualified tag names where+-- | Type alias for an annotated node with unqualified tag names where -- tag and text are the same string type type UNode a text = Node a text text --- | Type alias for a single annotated node, annotated with parse location+-- | Type alias for an annotated node, annotated with parse location type LNode tag text = Node XMLParseLocation tag text --- | Type alias for a single node with unqualified tag names where+-- | Type alias for an annotated node with unqualified tag names where -- tag and text are the same string type, annotated with parse location type ULNode text = LNode text text  --- | Type alias for a single annotated node where qualified names are used for tags+-- | Type alias for an annotated node where qualified names are used for tags type QNode a text = Node a (QName text) text --- | Type alias for a single node where qualified names are used for tags, annotated with parse location+-- | Type alias for an annotated node where qualified names are used for tags, annotated with parse location type QLNode text = LNode (QName text) text --- | Type alias for a single annotated node where namespaced names are used for tags+-- | Type alias for an annotated node where namespaced names are used for tags type NNode a text = Node a (NName text) text --- | Type alias for a single node where namespaced names are used for tags, annotated with parse location+-- | Type alias for an annotated node where namespaced names are used for tags, annotated with parse location type NLNode text = LNode (NName text) text  -- | Modify this node's annotation (non-recursively) if it's an element, otherwise no-op.@@ -254,10 +267,11 @@           -> (Node a tag text, Maybe XMLParseError) saxToTree events =     let (nodes, mError, _) = ptl events-    in  (safeHead nodes, mError)+    in  (findRoot nodes, mError)   where-    safeHead (a:_) = a-    safeHead [] = Element (gxFromString "") [] [] (error "saxToTree null annotation")+    findRoot (elt@(Element _ _ _ _):_) = elt+    findRoot (_:nodes) = findRoot nodes+    findRoot [] = Element (gxFromString "") [] [] (error "saxToTree null annotation")     ptl ((StartElement name attrs, ann):rema) =         let (children, err1, rema') = ptl rema             elt = Element name attrs children ann@@ -268,13 +282,14 @@         let (out, err, rema') = ptl rema         in  (Text txt:out, err, rema')     ptl ((FailDocument err, _):_) = ([], Just err, [])+    ptl (_:rema) = ptl rema  -- extended node types not supported in this tree type     ptl [] = ([], Nothing, [])  -- | Lazily parse XML to tree. Note that forcing the XMLParseError return value -- will force the entire parse.  Therefore, to ensure lazy operation, don't -- check the error status until you have processed the tree. parse :: (GenericXMLString tag, GenericXMLString text) =>-         ParseOptions tag text   -- ^ Optional encoding override+         ParseOptions tag text    -- ^ Parse options       -> L.ByteString             -- ^ Input text (a lazy ByteString)       -> (LNode tag text, Maybe XMLParseError) parse opts bs = saxToTree $ SAX.parseLocations opts bs@@ -299,7 +314,7 @@ -- situations where it's not expected during normal operation, depending on the -- design of your program. parseThrowing :: (GenericXMLString tag, GenericXMLString text) =>-                 ParseOptions tag text   -- ^ Optional encoding override+                 ParseOptions tag text    -- ^ Parse options               -> L.ByteString             -- ^ Input text (a lazy ByteString)               -> LNode tag text parseThrowing opts bs = fst $ saxToTree $ SAX.parseLocationsThrowing opts bs@@ -316,7 +331,7 @@  -- | Strictly parse XML to tree. Returns error message or valid parsed tree. parse' :: (GenericXMLString tag, GenericXMLString text) =>-          ParseOptions tag text  -- ^ Optional encoding override+          ParseOptions tag text   -- ^ Parse options        -> B.ByteString            -- ^ Input text (a strict ByteString)        -> Either XMLParseError (LNode tag text) parse' opts bs = case parse opts (L.fromChunks [bs]) of

@@ -0,0 +1,432 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeFamilies,+        FlexibleContexts, EmptyDataDecls #-}+-- | An extended variant of /Node/ intended to implement the entire XML+-- specification.  DTDs are not yet supported, however.+--+-- The names conflict with those in /Tree/ so you must use qualified import+-- if you want to use both modules.+module Text.XML.Expat.Extended (+  -- * Tree structure+  Document,+  DocumentG(..),+  Node,+  NodeG(..),+  UDocument,+  LDocument,+  ULDocument,+  UNode,+  LNode,+  ULNode,++  -- * Generic document/node manipulation+  module Text.XML.Expat.Internal.DocumentClass,+  module Text.XML.Expat.Internal.NodeClass,++  -- * Annotation-specific+  modifyAnnotation,+  mapAnnotation,+  mapDocumentAnnotation,++  -- * Qualified nodes+  QDocument,+  QLDocument,+  QNode,+  QLNode,+  module Text.XML.Expat.Internal.Qualified,++  -- * Namespaced nodes+  NDocument,+  NLDocument,+  NNode,+  NLNode,+  module Text.XML.Expat.Internal.Namespaced,++  -- * Parse to tree+  ParseOptions(..),+  defaultParseOptions,+  Encoding(..),+  parse,+  parse',+  XMLParseError(..),+  XMLParseLocation(..),++  -- * Variant that throws exceptions+  parseThrowing,+  XMLParseException(..),++  -- * Convert from SAX+  saxToTree,++  -- * Abstraction of string types+  GenericXMLString(..)+  ) where++import Control.Arrow+import Text.XML.Expat.SAX ( Encoding(..)+                          , GenericXMLString(..)+                          , ParseOptions(..)+                          , defaultParseOptions+                          , SAXEvent+                          , XMLParseError(..)+                          , XMLParseException(..)+                          , XMLParseLocation(..) )+import qualified Text.XML.Expat.SAX as SAX+import Text.XML.Expat.Internal.DocumentClass+import Text.XML.Expat.Internal.Namespaced+import Text.XML.Expat.Internal.NodeClass+import Text.XML.Expat.Internal.Qualified++import Control.Monad (mplus, mzero)+import Control.DeepSeq+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import Data.List.Class+import Data.Maybe+import Data.Monoid+++-- | Document representation of the XML document, intended to support the entire+-- XML specification.  DTDs are not yet supported, however.+data DocumentG a c tag text = Document {+        dXMLDeclaration          :: Maybe (XMLDeclaration text),+        dDocumentTypeDeclaration :: Maybe (DocumentTypeDeclaration c tag text),+        dTopLevelMiscs           :: c (Misc text),+        dRoot                    :: NodeG a c tag text+    }++instance (Show tag, Show text, Show a) => Show (DocumentG a [] tag text) where+    showsPrec d (Document xd dtd m r) = showParen (d > 10) $+        ("Document "++) . showsPrec 11 xd . (" "++) .+                          showsPrec 11 dtd . (" "++) .+                          showsPrec 11 m . (" "++) .+                          showsPrec 11 r++instance (Eq tag, Eq text, Eq a) => Eq (DocumentG a [] tag text) where+    Document xd1 dtd1 m1 r1 == Document xd2 dtd2 m2 r2 =+        xd1 == xd2 &&+        dtd1 == dtd2 &&+        m1 == m2 &&+        r1 == r2++-- | A pure representation of an XML document that uses a list as its container type.+type Document a tag text = DocumentG a [] tag text++type instance NodeType (DocumentG ann) = NodeG ann++instance (Functor c, List c) => DocumentClass (DocumentG ann) c where+    getXMLDeclaration          = dXMLDeclaration+    getDocumentTypeDeclaration = dDocumentTypeDeclaration+    getTopLevelMiscs           = dTopLevelMiscs+    getRoot                    = dRoot+    mkDocument                 = Document++-- | Extended variant of the tree representation of the XML document, intended+-- to support the entire XML specification.  DTDs are not yet supported, however.+--+-- @c@ is the container type for the element's children, which is [] in the+-- @hexpat@ package, and a monadic list type for @hexpat-iteratee@.+--+-- @tag@ is the tag type, which can either be one of several string types,+-- or a special type from the @Text.XML.Expat.Namespaced@ or+-- @Text.XML.Expat.Qualified@ modules.+--+-- @text@ is the string type for text content.+--+-- @a@ is the type of the annotation.  One of the things this can be used for+-- is to store the XML parse location, which is useful for error handling.+--+-- Note that some functions in the @Text.XML.Expat.Cursor@ module need to create+-- new nodes through the 'MkElementClass' type class. Normally this can only be done+-- if @a@ is a Maybe type or () (so it can provide the Nothing value for the annotation+-- on newly created nodes).  Or, you can write your own 'MkElementClass' instance.+-- Apart from that, there is no requirement for @a@ to be a Maybe type.+data NodeG a c tag text =+    Element {+        eName       :: !tag,+        eAttributes :: ![(tag,text)],+        eChildren   :: c (NodeG a c tag text),+        eAnn        :: a+    } |+    Text !text |+    CData !text |+    Misc (Misc text)++type instance ListOf (NodeG a c tag text) = c (NodeG a c tag text)++-- | A pure tree representation that uses a list as its container type,+-- extended variant.+--+-- In the @hexpat@ package, a list of nodes has the type @[Node tag text]@, but note+-- that you can also use the more general type function 'ListOf' to give a list of+-- any node type, using that node's associated list type, e.g.+-- @ListOf (UNode Text)@.+type Node a tag text = NodeG a [] tag text++instance (Show tag, Show text, Show a) => Show (NodeG a [] tag text) where+    showsPrec d (Element na at ch an) = showParen (d > 10) $+        ("Element "++) . showsPrec 11 na . (" "++) .+                         showsPrec 11 at . (" "++) .+                         showsPrec 11 ch . (" "++) .+                         showsPrec 11 an+    showsPrec d (Text t) = showParen (d > 10) $ ("Text "++) . showsPrec 11 t+    showsPrec d (CData t) = showParen (d > 10) $ ("CData "++) . showsPrec 11 t+    showsPrec d (Misc m)  = showParen (d > 10) $ ("Misc "++) . showsPrec 11 m++instance (Eq tag, Eq text, Eq a) => Eq (NodeG a [] tag text) where+    Element na1 at1 ch1 an1 == Element na2 at2 ch2 an2 =+        na1 == na2 &&+        at1 == at2 &&+        ch1 == ch2 &&+        an1 == an2+    Text t1 == Text t2 = t1 == t2+    CData t1 == CData t2 = t1 == t2+    Misc t1 == Misc t2 = t1 == t2+    _ == _ = False++instance (NFData tag, NFData text, NFData a) => NFData (NodeG a [] tag text) where+    rnf (Element nam att chi ann) = rnf (nam, att, chi, ann)+    rnf (Text txt) = rnf txt+    rnf (CData txt) = rnf txt+    rnf (Misc m) = rnf m++instance (Functor c, List c) => NodeClass (NodeG a) c where+    textContentM (Element _ _ children _) = foldlL mappend mempty $ joinM $ fmap textContentM children+    textContentM (Text txt) = return txt+    textContentM (CData txt) = return txt+    textContentM (Misc (ProcessingInstruction _ _)) = return mempty+    textContentM (Misc (Comment _)) = return mempty++    isElement (Element _ _ _ _) = True+    isElement _                 = False+    +    isText (Text _) = True+    isText (CData _) = True+    isText _        = False+    +    isCData (CData _) = True+    isCData _        = False+    +    isProcessingInstruction (Misc (ProcessingInstruction _ _)) = True+    isProcessingInstruction _        = False+    +    isComment (Misc (Comment _)) = True+    isComment _                  = False+    +    isNamed nm (Element nm' _ _ _) = nm == nm'+    isNamed _  _ = False+    +    getName (Element name _ _ _) = name+    getName _             = mempty+    +    hasTarget t (Misc (ProcessingInstruction t' _ )) = t == t'+    hasTarget _  _ = False+    +    getTarget (Misc (ProcessingInstruction target _)) = target+    getTarget _                                       = mempty++    getAttributes (Element _ attrs _ _) = attrs+    getAttributes _              = []++    getChildren (Element _ _ ch _) = ch+    getChildren _           = mzero++    getText (Text txt) = txt+    getText (CData txt) = txt+    getText (Misc (ProcessingInstruction _ txt)) = txt+    getText (Misc (Comment txt)) = txt+    getText (Element _ _ _ _) = mempty++    modifyName f (Element n a c ann) = Element (f n) a c ann+    modifyName _ node = node++    modifyAttributes f (Element n a c ann) = Element n (f a) c ann+    modifyAttributes _ node = node++    modifyChildren f (Element n a c ann) = Element n a (f c) ann+    modifyChildren _ node = node++    mapAllTags f (Element n a c ann) = Element (f n) (map (first f) a) (fmap (mapAllTags f) c) ann+    mapAllTags _ (Text txt) = Text txt+    mapAllTags _ (CData txt) = CData txt+    mapAllTags _ (Misc (ProcessingInstruction n txt)) = Misc (ProcessingInstruction n txt)+    mapAllTags _ (Misc (Comment txt)) = Misc (Comment txt)++    modifyElement f (Element n a c ann) =+        let (n', a', c') = f (n, a, c)+        in  Element n' a' c' ann+    modifyElement _ (Text txt) = Text txt+    modifyElement _ (CData txt) = CData txt+    modifyElement _ (Misc (ProcessingInstruction n txt)) = Misc (ProcessingInstruction n txt)+    modifyElement _ (Misc (Comment txt)) = Misc (Comment txt)++    mapNodeContainer f (Element n a ch an) = do+        ch' <- mapNodeListContainer f ch+        return $ Element n a ch' an+    mapNodeContainer _ (Text txt) = return $ (Text txt)+    mapNodeContainer _ (CData txt) = return $ (CData txt)+    mapNodeContainer _ (Misc (ProcessingInstruction n txt)) = return $ Misc (ProcessingInstruction n txt)+    mapNodeContainer _ (Misc (Comment txt)) = return $ Misc (Comment txt)++    mkText = Text++instance (Functor c, List c) => MkElementClass (NodeG (Maybe a)) c where+    mkElement name attrs children = Element name attrs children Nothing++instance (Functor c, List c) => MkElementClass (NodeG ()) c where+    mkElement name attrs children = Element name attrs children ()++-- | Type alias for an extended document with unqualified tag names where+-- tag and text are the same string type+type UDocument a text = Document a text text++-- | Type alias for an extended document, annotated with parse location+type LDocument tag text = Document XMLParseLocation tag text++-- | Type alias for an extended document with unqualified tag names where+-- tag and text are the same string type, annotated with parse location+type ULDocument text = Document XMLParseLocation text text++-- | Type alias for an extended document where qualified names are used for tags+type QDocument a text = Document a (QName text) text++-- | Type alias for an extended document where qualified names are used for tags, annotated with parse location+type QLDocument text = Document XMLParseLocation (QName text) text++-- | Type alias for an extended document where namespaced names are used for tags+type NDocument a text = Document a (NName text) text++-- | Type alias for an extended document where namespaced names are used for tags, annotated with parse location+type NLDocument text = Document XMLParseLocation (NName text) text++-- | Type alias for an extended node with unqualified tag names where+-- tag and text are the same string type+type UNode a text = Node a text text++-- | Type alias for an extended node, annotated with parse location+type LNode tag text = Node XMLParseLocation tag text++-- | Type alias for an extended node with unqualified tag names where+-- tag and text are the same string type, annotated with parse location+type ULNode text = LNode text text ++-- | Type alias for an extended node where qualified names are used for tags+type QNode a text = Node a (QName text) text++-- | Type alias for an extended node where qualified names are used for tags, annotated with parse location+type QLNode text = LNode (QName text) text++-- | Type alias for an extended node where namespaced names are used for tags+type NNode a text = Node a (NName text) text++-- | Type alias for an extended node where namespaced names are used for tags, annotated with parse location+type NLNode text = LNode (NName text) text++-- | Modify this node's annotation (non-recursively) if it's an element, otherwise no-op.+modifyAnnotation :: (a -> a) -> Node a tag text -> Node a tag text+f `modifyAnnotation` Element na at ch an = Element na at ch (f an)+_ `modifyAnnotation` Text t = Text t+_ `modifyAnnotation` CData t = CData t+_ `modifyAnnotation` Misc (ProcessingInstruction n t) = Misc (ProcessingInstruction n t)+_ `modifyAnnotation` Misc (Comment t) = Misc (Comment t)++-- | Modify this node's annotation and all its children recursively if it's an element, otherwise no-op.+mapAnnotation :: (a -> b) -> Node a tag text -> Node b tag text+f `mapAnnotation` Element na at ch an = Element na at (map (f `mapAnnotation`) ch) (f an)+_ `mapAnnotation` Text t = Text t+_ `mapAnnotation` CData t = CData t+_ `mapAnnotation` Misc (ProcessingInstruction n t) = Misc (ProcessingInstruction n t)+_ `mapAnnotation` Misc (Comment t) = Misc (Comment t)++-- | Modify the annotation of every node in the document recursively.+mapDocumentAnnotation :: (a -> b) -> Document a tag text -> Document b tag text+mapDocumentAnnotation f doc = Document {+        dXMLDeclaration          = dXMLDeclaration doc,+        dDocumentTypeDeclaration = dDocumentTypeDeclaration doc,+        dTopLevelMiscs           = dTopLevelMiscs doc,+        dRoot                    = mapAnnotation f (dRoot doc)+    }++-- | A lower level function that lazily converts a SAX stream into a tree structure.+-- Variant that takes annotations for start tags.+saxToTree :: (GenericXMLString tag, Monoid text) =>+             [(SAXEvent tag text, a)]+          -> (Document a tag text, Maybe XMLParseError)+saxToTree ((SAX.XMLDeclaration ver mEnc mSD, _):events) =+    let (doc, mErr) = saxToTree events+    in  (doc {+            dXMLDeclaration = Just $ XMLDeclaration ver mEnc mSD+        }, mErr)+saxToTree events =+    let (nodes, mError, _) = ptl events False []+        doc = Document {+                dXMLDeclaration          = Nothing,+                dDocumentTypeDeclaration = Nothing,+                dTopLevelMiscs           = findTopLevelMiscs nodes,+                dRoot                    = findRoot nodes+            }+    in  (doc, mError)+  where+    findRoot (elt@(Element _ _ _ _):_) = elt+    findRoot (_:nodes) = findRoot nodes+    findRoot [] = Element (gxFromString "") [] [] (error "saxToTree null annotation")+    findTopLevelMiscs = mapMaybe $ \node -> case node of+        Misc m -> Just m+        _      -> Nothing+    ptl ((SAX.StartElement name attrs,ann):rema) isCD cd =+        let (children, err1, rema') = ptl rema isCD cd+            elt = Element name attrs children ann+            (out, err2, rema'') = ptl rema' isCD cd+        in  (elt:out, err1 `mplus` err2, rema'')+    ptl ((SAX.EndElement _, _):rema) _ _ = ([], Nothing, rema)+    ptl ((SAX.CharacterData txt, _):rema) isCD cd =+        if isCD then+            ptl rema isCD (txt:cd)+        else+            let (out, err, rema') = ptl rema isCD cd+            in  (Text txt:out, err, rema')+    ptl ((SAX.StartCData,_) :rema) _ _ =+        ptl rema True mzero+    ptl ((SAX.EndCData, _) :rema) _ cd =+        let (out, err, rema') = ptl rema False mzero+        in  (CData (mconcat $ reverse cd):out, err, rema')+    ptl ((SAX.Comment txt, _):rema) isCD cd =+        let (out, err, rema') = ptl rema isCD cd+        in  (Misc (Comment txt):out, err, rema')+    ptl ((SAX.ProcessingInstruction target txt, _):rema) isCD cd =+        let (out, err, rema') = ptl rema isCD cd+        in  (Misc (ProcessingInstruction target txt):out, err, rema')+    ptl ((SAX.FailDocument err, _):_) _ _ = ([], Just err, [])+    ptl ((SAX.XMLDeclaration _ _ _, _):rema) isCD cd = ptl rema isCD cd  -- doesn't appear in the middle of a document+    ptl [] _ _ = ([], Nothing, [])++-- | Lazily parse XML to tree. Note that forcing the XMLParseError return value+-- will force the entire parse.  Therefore, to ensure lazy operation, don't+-- check the error status until you have processed the tree.+parse :: (GenericXMLString tag, GenericXMLString text) =>+         ParseOptions tag text    -- ^ Parse options+      -> L.ByteString             -- ^ Input text (a lazy ByteString)+      -> (LDocument tag text, Maybe XMLParseError)+parse opts bs = saxToTree $ SAX.parseLocations opts bs++-- | Lazily parse XML to tree. In the event of an error, throw 'XMLParseException'.+--+-- @parseThrowing@ can throw an exception from pure code, which is generally a bad+-- way to handle errors, because Haskell\'s lazy evaluation means it\'s hard to+-- predict where it will be thrown from.  However, it may be acceptable in+-- situations where it's not expected during normal operation, depending on the+-- design of your program.+parseThrowing :: (GenericXMLString tag, GenericXMLString text) =>+                 ParseOptions tag text    -- ^ Parse options+              -> L.ByteString             -- ^ Input text (a lazy ByteString)+              -> LDocument tag text+parseThrowing opts bs = fst $ saxToTree $ SAX.parseLocationsThrowing opts bs++-- | Strictly parse XML to tree. Returns error message or valid parsed tree.+parse' :: (GenericXMLString tag, GenericXMLString text) =>+          ParseOptions tag text   -- ^ Parse options+       -> B.ByteString            -- ^ Input text (a strict ByteString)+       -> Either XMLParseError (LDocument tag text)+parse' opts bs = case parse opts (L.fromChunks [bs]) of+    (_, Just err)   -> Left err+    (root, Nothing) -> Right root +

@@ -5,6 +5,17 @@  -- | This module provides functions to format a tree -- structure or SAX stream as UTF-8 encoded XML.+--+-- The formatting functions always outputs only UTF-8, regardless+-- of what encoding is specified in the document's 'Doc.XMLDeclaration'.+-- If you want to output a document in another encoding, then make sure the+-- 'Doc.XMLDeclaration' agrees with the final output encoding, then format the+-- document, and convert from UTF-8 to your desired encoding using some text+-- conversion library.+--+-- The lazy 'L.ByteString' representation of the output in generated with very+-- small chunks, so in some applications you may want to combine them into+-- larger chunks to get better efficiency. module Text.XML.Expat.Format (         -- * High level         format,@@ -13,12 +24,17 @@         formatNode,         formatNode',         formatNodeG,+        -- * Format document (for use with Extended.hs)+        formatDocument,+        formatDocument',+        formatDocumentG,         -- * Deprecated names         formatTree,         formatTree',         -- * Low level         xmlHeader,         treeToSAX,+        documentToSAX,         formatSAX,         formatSAX',         formatSAXG,@@ -27,6 +43,7 @@         indent_     ) where +import qualified Text.XML.Expat.Internal.DocumentClass as Doc import Text.XML.Expat.Internal.NodeClass import Text.XML.Expat.SAX @@ -89,10 +106,44 @@            -> c B.ByteString formatNodeG = formatSAXG . treeToSAX +-- | Format an XML document - lazy variant that returns lazy ByteString.+formatDocument :: (Doc.DocumentClass d [], GenericXMLString tag, GenericXMLString text) =>+                  d [] tag text+               -> L.ByteString+formatDocument = formatSAX . documentToSAX++-- | Format an XML document - strict variant that returns strict ByteString.+formatDocument' :: (Doc.DocumentClass d [], GenericXMLString tag, GenericXMLString text) =>+                   d [] tag text+                -> B.ByteString+formatDocument' = B.concat . L.toChunks . formatDocument++-- | Format an XML document - generalized variant that returns a generic+-- list of strict ByteStrings.+formatDocumentG :: (Doc.DocumentClass d c, GenericXMLString tag, GenericXMLString text) =>+                   d c tag text+                -> c B.ByteString+formatDocumentG = formatSAXG . documentToSAX+ -- | The standard XML header with UTF-8 encoding. xmlHeader :: B.ByteString xmlHeader = B.pack $ map c2w "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n" +documentToSAX :: forall tag text d c . (GenericXMLString tag, GenericXMLString text,+                     Monoid text, Doc.DocumentClass d c) =>+                 d c tag text -> c (SAXEvent tag text)+documentToSAX doc =+    (case Doc.getXMLDeclaration doc of+        Just (Doc.XMLDeclaration ver mEnc sd) -> fromList [+                  XMLDeclaration ver mEnc sd, CharacterData (gxFromString "\n")]+        Nothing                               -> mzero) `mplus`+    join (fmap (\misc -> fromList [case misc of+            Doc.ProcessingInstruction target text -> ProcessingInstruction target text+            Doc.Comment text                      -> Comment text,+            CharacterData (gxFromString "\n")]+        ) (Doc.getTopLevelMiscs doc)) `mplus`+    treeToSAX (Doc.getRoot doc)+ -- | Flatten a tree structure into SAX events, monadic version. treeToSAX :: forall tag text n c . (GenericXMLString tag, GenericXMLString text,                  Monoid text, NodeClass n c) =>@@ -110,8 +161,14 @@                     Cons n l' -> cons n (postpend l')         in  cons (StartElement name atts) $             postpend (concatL $ fmap treeToSAX children)+    | isCData node =+        cons StartCData (cons (CharacterData $ getText node) (singleton EndCData))     | isText node =-        singleton (CharacterData $ getText node)+        singleton (CharacterData $ getText node)        +    | isProcessingInstruction node =+        singleton (ProcessingInstruction (getTarget node) (getText node))+    | isComment node =+        singleton (Comment $ getText node)         | otherwise = mzero   where     singleton = return@@ -152,12 +209,40 @@               GenericXMLString text) =>           c (SAXEvent tag text)    -- ^ SAX events        -> c B.ByteString-formatSAXG l1 = joinL $ do+formatSAXG l1 = formatSAXGb l1 False++formatSAXGb :: forall c tag text . (List c, GenericXMLString tag,+              GenericXMLString text) =>+          c (SAXEvent tag text)    -- ^ SAX events+       -> Bool                     -- ^ True if processing CDATA+       -> c B.ByteString+formatSAXGb l1 cd = joinL $ do     it1 <- runList l1     return $ formatItem it1   where     formatItem it1 = case it1 of         Nil -> mzero+        Cons (XMLDeclaration ver mEnc mSD) l2 ->+            return (pack "<?xml version=\"") `mplus`+            fromList (escapeText (gxToByteString ver)) `mplus`+            return (pack "\"") `mplus`+            (+                case mEnc of+                    Nothing -> mzero+                    Just enc ->+                        return (pack " encoding=\"") `mplus`+                        fromList (escapeText (gxToByteString enc)) `mplus`+                        return (pack "\"")+            ) `mplus`+            (+                case mSD of+                    Nothing -> mzero+                    Just True  -> return (pack " standalone=\"yes\"")+                    Just False -> return (pack " standalone=\"no\"")+            ) `mplus`+            return (pack ("?>"))+            `mplus`+            formatSAXGb l2 cd         Cons (StartElement name attrs) l2 ->             fromList (startTagHelper name attrs)             `mplus` (@@ -166,7 +251,7 @@                     return $ case it2 of                         Cons (EndElement _) l3 ->                             cons (pack "/>") $-                            formatSAXG l3+                            formatSAXGb l3 cd                         _ ->                             cons (B.singleton (c2w '>')) $                             formatItem it2@@ -175,13 +260,33 @@             cons (pack "</") $             cons (gxToByteString name) $             cons (B.singleton (c2w '>')) $-            formatSAXG l2+            formatSAXGb l2 cd         Cons (CharacterData txt) l2 ->-            fromList (escapeText (gxToByteString txt))-            `mplus`-            formatSAXG l2+            (if cd then+                fromList [gxToByteString txt]+             else+                fromList (escapeText (gxToByteString txt))+            ) `mplus` (formatSAXGb l2 cd)+        Cons StartCData l2 ->+            cons(pack "<![CDATA[") $+            formatSAXGb l2 True+        Cons EndCData l2 ->+            cons(pack "]]>") $+            formatSAXGb l2 False+        Cons (ProcessingInstruction target txt) l2 ->+            cons (pack "<?") $+            cons (gxToByteString target) $+            cons (pack " ") $+            cons (gxToByteString txt) $+            cons (pack "?>") $+            formatSAXGb l2 cd+        Cons (Comment txt) l2 ->+            cons (pack "<!--") $+            cons (gxToByteString txt) $+            cons (pack "-->") $+            formatSAXGb l2 cd         Cons (FailDocument _) l2 ->-            formatSAXG l2+            formatSAXGb l2 cd  pack :: String -> B.ByteString pack = B.pack . map c2w

@@ -0,0 +1,98 @@+{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleContexts #-}+-- | Type classes to allow for XML handling functions to be generalized to+-- work with different document types.+module Text.XML.Expat.Internal.DocumentClass where++import Text.XML.Expat.Internal.NodeClass (NodeClass)+import Control.DeepSeq+import Control.Monad (mzero)+import Data.List.Class+++-- | XML declaration, consisting of version, encoding and standalone.+--+-- The formatting functions always outputs only UTF-8, regardless+-- of what encoding is specified here.  If you want to produce a document in a+-- different encoding, then set the encoding here, format the document, and then+-- convert the output text from UTF-8 to your desired encoding using some+-- text conversion library.+data XMLDeclaration text = XMLDeclaration text (Maybe text) (Maybe Bool) deriving (Eq, Show)++-- | Stub for future expansion.+data DocumentTypeDeclaration c tag text = DocumentTypeDeclaration deriving (Eq, Show)++data Misc text =+    Comment !text |+    ProcessingInstruction !text !text++instance Show text => Show (Misc text) where+    showsPrec d (ProcessingInstruction t txt) = showParen (d > 10) $+        ("ProcessingInstruction "++) . showsPrec 11 t . (" "++) . showsPrec 11 txt+    showsPrec d (Comment t) = showParen (d > 10) $ ("Comment "++) . showsPrec 11 t++instance Eq text => Eq (Misc text) where+    ProcessingInstruction t1 d1 == ProcessingInstruction t2 d2 = +        t1 == t2 &&+        d1 == d2+    Comment t1 == Comment t2 = t1 == t2+    _ == _ = False++instance NFData text => NFData (Misc text) where+    rnf (ProcessingInstruction target txt) = rnf (target, txt)+    rnf (Comment txt) = rnf txt++type family NodeType d :: (* -> *) -> * -> * -> *++class (Functor c, List c, NodeClass (NodeType d) c) => DocumentClass d c where+    -- | Get the XML declaration for this document.+    getXMLDeclaration :: d c tag text -> Maybe (XMLDeclaration text)++    -- | Get the Document Type Declaration (DTD) for this document.+    getDocumentTypeDeclaration :: d c tag text -> Maybe (DocumentTypeDeclaration c tag text)++    -- | Get the top-level 'Misc' nodes for this document.+    getTopLevelMiscs :: d c tag text -> c (Misc text)++    -- | Get the root element for this document.+    getRoot :: d c tag text -> NodeType d c tag text++    -- | Make a document with the specified fields.+    mkDocument :: Maybe (XMLDeclaration text)+               -> Maybe (DocumentTypeDeclaration c tag text)+               -> c (Misc text)+               -> NodeType d c tag text+               -> d c tag text++-- | Make a document with the specified root node and all other information+-- set to defaults.+mkPlainDocument :: DocumentClass d c => NodeType d c tag text -> d c tag text+mkPlainDocument = mkDocument Nothing Nothing mzero++modifyXMLDeclaration :: DocumentClass d c =>+                        (Maybe (XMLDeclaration text) -> Maybe (XMLDeclaration text))+                     -> d c tag text+                     -> d c tag text+modifyXMLDeclaration f doc = mkDocument (f $ getXMLDeclaration doc) (getDocumentTypeDeclaration doc)+        (getTopLevelMiscs doc) (getRoot doc)++modifyDocumentTypeDeclaration :: DocumentClass d c =>+                                 (Maybe (DocumentTypeDeclaration c tag text) -> Maybe (DocumentTypeDeclaration c tag text))+                              -> d c tag text+                              -> d c tag text+modifyDocumentTypeDeclaration f doc = mkDocument (getXMLDeclaration doc) (f $ getDocumentTypeDeclaration doc)+        (getTopLevelMiscs doc) (getRoot doc)++modifyTopLevelMiscs :: DocumentClass d c =>+                       (c (Misc text) -> c (Misc text))+                    -> d c tag text+                    -> d c tag text+modifyTopLevelMiscs f doc = mkDocument (getXMLDeclaration doc) (getDocumentTypeDeclaration doc)+        (f $ getTopLevelMiscs doc) (getRoot doc)++modifyRoot :: DocumentClass d c =>+              (NodeType d c tag text -> NodeType d c tag text)+           -> d c tag text+           -> d c tag text+modifyRoot f doc = mkDocument (getXMLDeclaration doc) (getDocumentTypeDeclaration doc)+        (getTopLevelMiscs doc) (f $ getRoot doc)+

@@ -1,12 +1,8 @@ {-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-} --- hexpat, a Haskell wrapper for expat--- Copyright (C) 2008 Evan Martin <martine@danga.com>--- Copyright (C) 2009 Stephen Blackheath <http://blacksapphire.com/antispam>- -- | Low-level interface to Expat. Unless speed is paramount, this should -- normally be avoided in favour of the interfaces provided by--- 'Text.XML.Expat.SAX' and 'Text.XML.Expat.Tree'.  Basic usage is:+-- 'Text.XML.Expat.SAX' and 'Text.XML.Expat.Tree', etc.  Basic usage is: -- -- (1) Make a new parser: 'newParser'. --@@ -30,14 +26,24 @@   XMLParseLocation(..),    -- ** Parser Callbacks+  XMLDeclarationHandler,   StartElementHandler,   EndElementHandler,   CharacterDataHandler,   ExternalEntityRefHandler,   SkippedEntityHandler,+  StartCDataHandler,+  EndCDataHandler,+  CommentHandler,+  ProcessingInstructionHandler,+  setXMLDeclarationHandler,   setStartElementHandler,   setEndElementHandler,   setCharacterDataHandler,+  setStartCDataHandler,+  setEndCDataHandler,+  setProcessingInstructionHandler,+  setCommentHandler,   setExternalEntityRefHandler,   setSkippedEntityHandler,   setUseForeignDTD,@@ -64,16 +70,21 @@ data Parser_struct type ParserPtr = Ptr Parser_struct data Parser = Parser-    { _parserObj                :: ForeignPtr Parser_struct-    , _startElementHandler      :: IORef CStartElementHandler-    , _endElementHandler        :: IORef CEndElementHandler-    , _cdataHandler             :: IORef CCharacterDataHandler-    , _externalEntityRefHandler :: IORef (Maybe CExternalEntityRefHandler)-    , _skippedEntityHandler     :: IORef (Maybe CSkippedEntityHandler)+    { _parserObj                    :: ForeignPtr Parser_struct+    , _xmlDeclarationHandler        :: IORef CXMLDeclarationHandler+    , _startElementHandler          :: IORef CStartElementHandler+    , _endElementHandler            :: IORef CEndElementHandler+    , _cdataHandler                 :: IORef CCharacterDataHandler+    , _externalEntityRefHandler     :: IORef (Maybe CExternalEntityRefHandler)+    , _skippedEntityHandler         :: IORef (Maybe CSkippedEntityHandler)+    , _startCDataHandler            :: IORef CStartCDataHandler+    , _endCDataHandler              :: IORef CEndCDataHandler+    , _processingInstructionHandler :: IORef CProcessingInstructionHandler+    , _commentHandler               :: IORef CCommentHandler     }  instance Show Parser where-    showsPrec _ (Parser fp _ _ _ _ _) = showsPrec 0 fp+    showsPrec _ (Parser fp _ _ _ _ _ _ _ _ _ _) = showsPrec 0 fp  -- |Encoding types available for the document encoding. data Encoding = ASCII | UTF8 | UTF16 | ISO88591@@ -98,16 +109,22 @@ -- | Create a 'Parser'. newParser :: Maybe Encoding -> IO Parser newParser enc = do-  ptr        <- parserCreate enc-  fptr       <- newForeignPtr parserFree ptr-  nullStartH <- newIORef nullCStartElementHandler-  nullEndH   <- newIORef nullCEndElementHandler-  nullCharH  <- newIORef nullCCharacterDataHandler-  extH       <- newIORef Nothing-  skipH      <- newIORef Nothing--  return $ Parser fptr nullStartH nullEndH nullCharH extH skipH+  ptr          <- parserCreate enc+  fptr         <- newForeignPtr parserFree ptr+  nullXMLDeclH <- newIORef nullCXMLDeclarationHandler+  nullStartH   <- newIORef nullCStartElementHandler+  nullEndH     <- newIORef nullCEndElementHandler+  nullCharH    <- newIORef nullCCharacterDataHandler+  extH         <- newIORef Nothing+  skipH        <- newIORef Nothing+  nullSCDataH  <- newIORef nullCStartCDataHandler+  nullECDataH  <- newIORef nullCEndCDataHandler+  nullPIH      <- newIORef nullCProcessingInstructionHandler+  nullCommentH <- newIORef nullCCommentHandler +  return $ Parser fptr nullXMLDeclH nullStartH nullEndH nullCharH extH skipH +    nullSCDataH nullECDataH nullPIH nullCommentH+   setUseForeignDTD :: Parser -> Bool -> IO () setUseForeignDTD p b = withParser p $ \p' -> xmlUseForeignDTD p' b'   where@@ -188,21 +205,27 @@     (FunPtr CCharacterDataHandler)     (Maybe (FunPtr CExternalEntityRefHandler))     (Maybe (FunPtr CSkippedEntityHandler))+    (FunPtr CStartCDataHandler)+    (FunPtr CEndCDataHandler)+    (FunPtr CProcessingInstructionHandler)+    (FunPtr CCommentHandler)  -- | Most of the low-level functions take a ParserPtr so are required to be -- called inside @withParser@. withParser :: Parser            -> (ParserPtr -> IO a)  -- ^ Computation where parseChunk and other low-level functions may be used            -> IO a-withParser parser@(Parser fp _ _ _ _ _) code = withForeignPtr fp $ \pp -> do+withParser parser@(Parser fp _ _ _ _ _ _ _ _ _ _) code = withForeignPtr fp $ \pp -> do     bracket         (unsafeSetHandlers parser pp)         unsafeReleaseHandlers         (\_ -> code pp)   where     unsafeSetHandlers :: Parser -> ParserPtr -> IO ExpatHandlers-    unsafeSetHandlers (Parser _ startRef endRef charRef extRef skipRef) pp =+    unsafeSetHandlers (Parser _ xmlDeclRef startRef endRef charRef extRef skipRef +        startCDataRef endCDataRef processingInstructionRef commentRef) pp =       do+        cXMLDeclH <- mkCXMLDeclarationHandler =<< readIORef xmlDeclRef         cStartH <- mkCStartElementHandler =<< readIORef startRef         cEndH   <- mkCEndElementHandler =<< readIORef endRef         cCharH  <- mkCCharacterDataHandler =<< readIORef charRef@@ -213,10 +236,21 @@         mSkipH  <- readIORef skipRef >>=                        maybe (return Nothing)                              (\h -> liftM Just $ mkCSkippedEntityHandler h)+                             +        cStartCDataH <- mkCStartCDataHandler =<< readIORef startCDataRef+        cEndCDataH   <- mkCEndCDataHandler =<< readIORef endCDataRef+        +        cProcessingInstructionH   <- mkCProcessingInstructionHandler =<< readIORef processingInstructionRef+        cCommentH   <- mkCCommentHandler =<< readIORef commentRef     +        xmlSetxmldeclhandler       pp cXMLDeclH         xmlSetstartelementhandler  pp cStartH         xmlSetendelementhandler    pp cEndH         xmlSetcharacterdatahandler pp cCharH+        xmlSetstartcdatahandler  pp cStartCDataH+        xmlSetendcdatahandler    pp cEndCDataH+        xmlSetprocessinginstructionhandler pp cProcessingInstructionH+        xmlSetcommenthandler pp cCommentH         maybe (return ())               (xmlSetExternalEntityRefHandler pp)               mExtH@@ -224,16 +258,21 @@               (xmlSetSkippedEntityHandler pp)               mSkipH     -        return $ ExpatHandlers cStartH cEndH cCharH mExtH mSkipH+        return $ ExpatHandlers cStartH cEndH cCharH mExtH mSkipH +            cStartCDataH cEndCDataH cProcessingInstructionH cCommentH          unsafeReleaseHandlers :: ExpatHandlers -> IO ()-    unsafeReleaseHandlers (ExpatHandlers cStartH cEndH cCharH mcExtH mcSkipH) = do+    unsafeReleaseHandlers (ExpatHandlers cStartH cEndH cCharH mcExtH mcSkipH +            cStartCDataH cEndCDataH cProcessingInstructionH cCommentH) = do         freeHaskellFunPtr cStartH         freeHaskellFunPtr cEndH         freeHaskellFunPtr cCharH         maybe (return ()) freeHaskellFunPtr mcExtH         maybe (return ()) freeHaskellFunPtr mcSkipH-+        freeHaskellFunPtr cStartCDataH+        freeHaskellFunPtr cEndCDataH+        freeHaskellFunPtr cProcessingInstructionH+        freeHaskellFunPtr cCommentH  -- |Obtain C value from Haskell 'Bool'. --@@ -279,6 +318,12 @@             xmlByteCount = fromIntegral count         } +-- | The type of the \"XML declaration\" callback.  Parameters are version,+-- encoding (which can be nullPtr), and standalone declaration, where -1 = no+-- declaration, 0 = "no" and 1 = "yes". Return True to continue parsing as+-- normal, or False to terminate the parse.+type XMLDeclarationHandler = ParserPtr -> CString -> CString -> CInt -> IO Bool+ -- | The type of the \"element started\" callback.  The first parameter is the -- element name; the second are the (attribute, value) pairs. Return True to -- continue parsing as normal, or False to terminate the parse.@@ -295,6 +340,25 @@ -- parsing as normal, or False to terminate the parse. type CharacterDataHandler = ParserPtr -> CStringLen -> IO Bool +-- | The type of the \"start cdata\" callback.   Return True to continue+-- parsing as normal, or False to terminate the parse.+type StartCDataHandler = ParserPtr -> IO Bool++-- | The type of the \"end cdata\" callback.   Return True to continue+-- parsing as normal, or False to terminate the parse.+type EndCDataHandler = ParserPtr -> IO Bool++-- | The type of the \"processing instruction\" callback.  The first parameter+-- is the first word in the processing instruction.  The second parameter is+-- the rest of the characters in the processing instruction after skipping all+-- whitespace after the initial word. Return True to continue parsing as normal,+-- or False to terminate the parse.+type ProcessingInstructionHandler = ParserPtr -> CString -> CString -> IO Bool++-- | The type of the \"comment\" callback.  The parameter is the comment text.+-- Return True to continue parsing as normal, or False to terminate the parse.+type CommentHandler = ParserPtr -> CString -> IO Bool+ -- | The type of the \"external entity reference\" callback. See the expat -- documentation. type ExternalEntityRefHandler =  Parser@@ -316,6 +380,35 @@                           -> Int       -- is a parameter entity?                           -> IO Bool ++type CXMLDeclarationHandler = ParserPtr -> CString -> CString -> CInt -> IO ()++nullCXMLDeclarationHandler :: CXMLDeclarationHandler+nullCXMLDeclarationHandler _ _ _ _ = return ()++foreign import ccall safe "wrapper"+  mkCXMLDeclarationHandler :: CXMLDeclarationHandler+                           -> IO (FunPtr CXMLDeclarationHandler)++wrapXMLDeclarationHandler :: Parser -> XMLDeclarationHandler -> CXMLDeclarationHandler+wrapXMLDeclarationHandler parser handler = h+  where+    h pp ver enc sd | ver /= nullPtr = do+        stillRunning <- handler pp ver enc sd+        unless stillRunning $ stopp parser+    {- From expat.h:+       The XML declaration handler is called for *both* XML declarations+       and text declarations. The way to distinguish is that the version+       parameter will be NULL for text declarations.+     -}+    h _ _ _ _ = return ()  -- text declaration (ignore)++-- | Attach a XMLDeclarationHandler to a Parser.+setXMLDeclarationHandler :: Parser -> XMLDeclarationHandler -> IO ()+setXMLDeclarationHandler parser@(Parser _ xmlDeclRef _ _ _ _ _ _ _ _ _) handler =+    writeIORef xmlDeclRef $ wrapXMLDeclarationHandler parser handler++ type CStartElementHandler = ParserPtr -> CString -> Ptr CString -> IO ()  nullCStartElementHandler :: CStartElementHandler@@ -335,9 +428,10 @@  -- | Attach a StartElementHandler to a Parser. setStartElementHandler :: Parser -> StartElementHandler -> IO ()-setStartElementHandler parser@(Parser _ startRef _ _ _ _) handler =+setStartElementHandler parser@(Parser _ _ startRef _ _ _ _ _ _ _ _) handler =     writeIORef startRef $ wrapStartElementHandler parser handler + type CEndElementHandler = ParserPtr -> CString -> IO ()  nullCEndElementHandler :: CEndElementHandler@@ -355,9 +449,10 @@  -- | Attach an EndElementHandler to a Parser. setEndElementHandler :: Parser -> EndElementHandler -> IO ()-setEndElementHandler parser@(Parser _ _ endRef _ _ _) handler =+setEndElementHandler parser@(Parser _ _ _ endRef _ _ _ _ _ _ _) handler =     writeIORef endRef $ wrapEndElementHandler parser handler + type CCharacterDataHandler = ParserPtr -> CString -> CInt -> IO ()  nullCCharacterDataHandler :: CCharacterDataHandler@@ -375,9 +470,98 @@  -- | Attach an CharacterDataHandler to a Parser. setCharacterDataHandler :: Parser -> CharacterDataHandler -> IO ()-setCharacterDataHandler parser@(Parser _ _ _ charRef _ _) handler =+setCharacterDataHandler parser@(Parser _ _ _ _ charRef _ _ _ _ _ _) handler =     writeIORef charRef $ wrapCharacterDataHandler parser handler ++type CStartCDataHandler = ParserPtr -> IO ()++nullCStartCDataHandler :: CStartCDataHandler+nullCStartCDataHandler _ = return ()++foreign import ccall safe "wrapper"+  mkCStartCDataHandler :: CStartCDataHandler+                         -> IO (FunPtr CStartCDataHandler)++wrapStartCDataHandler :: Parser -> StartCDataHandler -> CStartCDataHandler+wrapStartCDataHandler parser handler = h+  where+    h pp = do+        stillRunning <- handler pp+        unless stillRunning $ stopp parser++-- | Attach a StartCDataHandler to a Parser.+setStartCDataHandler :: Parser -> StartCDataHandler -> IO ()+setStartCDataHandler parser@(Parser _ _ _ _ _ _ _ startCData _ _ _) handler =+    writeIORef startCData $ wrapStartCDataHandler parser handler+++type CEndCDataHandler = ParserPtr -> IO ()++nullCEndCDataHandler :: CEndCDataHandler+nullCEndCDataHandler _ = return ()++foreign import ccall safe "wrapper"+  mkCEndCDataHandler :: CEndCDataHandler+                         -> IO (FunPtr CEndCDataHandler)++wrapEndCDataHandler :: Parser -> EndCDataHandler -> CEndCDataHandler+wrapEndCDataHandler parser handler = h+  where+    h pp = do+        stillRunning <- handler pp+        unless stillRunning $ stopp parser++-- | Attach a EndCDataHandler to a Parser.+setEndCDataHandler :: Parser -> EndCDataHandler -> IO ()+setEndCDataHandler parser@(Parser _ _ _ _ _ _ _ _ endCData _ _) handler =+    writeIORef endCData $ wrapEndCDataHandler parser handler+++type CProcessingInstructionHandler = ParserPtr -> CString -> CString -> IO ()++nullCProcessingInstructionHandler :: CProcessingInstructionHandler+nullCProcessingInstructionHandler _ _ _ = return ()++foreign import ccall safe "wrapper"+  mkCProcessingInstructionHandler :: CProcessingInstructionHandler+                          -> IO (FunPtr CProcessingInstructionHandler)+                          +wrapProcessingInstructionHandler :: Parser -> ProcessingInstructionHandler -> CProcessingInstructionHandler+wrapProcessingInstructionHandler parser handler = h+  where+    h pp ctarget cdata = do+        stillRunning <- handler pp ctarget cdata+        unless stillRunning $ stopp parser++-- | Attach a ProcessingInstructionHandler to a Parser.+setProcessingInstructionHandler :: Parser -> ProcessingInstructionHandler -> IO ()+setProcessingInstructionHandler parser@(Parser _ _ _ _ _ _ _ _ _ piRef _) handler =+    writeIORef piRef $ wrapProcessingInstructionHandler parser handler+++type CCommentHandler = ParserPtr -> CString -> IO ()++nullCCommentHandler :: CCommentHandler+nullCCommentHandler _ _ = return ()++foreign import ccall safe "wrapper"+  mkCCommentHandler :: CCommentHandler+                          -> IO (FunPtr CCommentHandler)+                          +wrapCommentHandler :: Parser -> CommentHandler -> CCommentHandler+wrapCommentHandler parser handler = h+  where+    h pp cdata = do+        stillRunning <- handler pp cdata+        unless stillRunning $ stopp parser++-- | Attach a CommentHandler to a Parser.+setCommentHandler :: Parser -> CommentHandler -> IO ()+setCommentHandler parser@(Parser _ _ _ _ _ _ _ _ _ _ commentRef) handler =+    writeIORef commentRef $ wrapCommentHandler parser handler++ pairwise :: [a] -> [(a,a)] pairwise (x1:x2:xs) = (x1,x2) : pairwise xs pairwise _          = []@@ -394,14 +578,29 @@ foreign import ccall unsafe "XML_SetUserData"   xmlSetUserData :: ParserPtr -> ParserPtr -> IO () +foreign import ccall unsafe "XML_SetXmlDeclHandler"+  xmlSetxmldeclhandler :: ParserPtr -> FunPtr CXMLDeclarationHandler -> IO ()+ foreign import ccall unsafe "XML_SetStartElementHandler"   xmlSetstartelementhandler :: ParserPtr -> ((FunPtr (ParserPtr -> ((Ptr CChar) -> ((Ptr (Ptr CChar)) -> (IO ())))) -> (IO ())))  foreign import ccall unsafe "XML_SetEndElementHandler"   xmlSetendelementhandler :: ParserPtr -> ((FunPtr (ParserPtr -> ((Ptr CChar) -> (IO ()))) -> (IO ())))-+   foreign import ccall unsafe "XML_SetCharacterDataHandler"   xmlSetcharacterdatahandler :: ParserPtr -> ((FunPtr (ParserPtr -> ((Ptr CChar) -> (CInt -> (IO ())))) -> (IO ())))+  +foreign import ccall unsafe "XML_SetStartCdataSectionHandler"+  xmlSetstartcdatahandler :: ParserPtr -> FunPtr CStartCDataHandler -> IO ()++foreign import ccall unsafe "XML_SetEndCdataSectionHandler"+  xmlSetendcdatahandler :: ParserPtr -> FunPtr CStartCDataHandler -> IO ()+  +foreign import ccall unsafe "XML_SetCommentHandler"+  xmlSetcommenthandler :: ParserPtr -> ((FunPtr (ParserPtr -> ((Ptr CChar) -> (IO ()))) -> (IO ())))+  +foreign import ccall unsafe "XML_SetProcessingInstructionHandler"+  xmlSetprocessinginstructionhandler :: ParserPtr -> ((FunPtr (ParserPtr -> ((Ptr CChar) -> ((Ptr CChar) -> (IO ())))) -> (IO ())))  foreign import ccall safe "XML_Parse"   doParseChunk'_ :: ParserPtr -> ((Ptr CChar) -> (CInt -> (CInt -> (IO CInt))))

@@ -20,7 +20,8 @@ type UAttributes text = Attributes text text  -- | Extract all text content from inside a tag into a single string, including--- any text contained in children.+-- any text contained in children.  This /excludes/ the contents of /comments/ or+-- /processing instructions/.  To get the text for these node types, use 'getText'. textContent :: (NodeClass n [], Monoid text) => n [] tag text -> text textContent node = runIdentity $ textContentM node @@ -35,9 +36,19 @@      -- | Is the given node text?     isText :: n c tag text -> Bool+    +    -- | Is the given node CData?+    isCData :: n c tag text -> Bool+    +    -- | Is the given node a processing instruction?+    isProcessingInstruction :: n c tag text -> Bool+    +    -- | Is the given node a comment?+    isComment :: n c tag text -> Bool      -- | Extract all text content from inside a tag into a single string, including-    -- any text contained in children.+    -- any text contained in children.  This /excludes/ the contents of /comments/ or+    -- /processing instructions/.  To get the text for these node types, use 'getText'.     textContentM :: Monoid text => n c tag text -> ItemM c text      -- | Is the given node a tag with the given name?@@ -45,14 +56,21 @@      -- | Get the name of this node if it's an element, return empty string otherwise.     getName :: Monoid tag => n c tag text -> tag+    +    -- | Is the given node a Processing Instruction with the given target?+    hasTarget :: Eq text => text -> n c tag text -> Bool +    -- | Get the target of this node if it's a Processing Instruction, return empty string otherwise.+    getTarget :: Monoid text => n c tag text -> text+     -- | Get the attributes of a node if it's an element, return empty list otherwise.     getAttributes :: n c tag text -> [(tag,text)]      -- | Get children of a node if it's an element, return empty list otherwise.     getChildren :: n c tag text -> c (n c tag text) -    -- | Get this node's text if it's a text node, return empty text otherwise.+    -- | Get this node's text if it's a text node, comment, or processing instruction,+    -- return empty text otherwise.     getText :: Monoid text => n c tag text -> text      -- | Modify name if it's an element, no-op otherwise.

@@ -138,19 +138,28 @@   data SAXEvent tag text =+    XMLDeclaration text (Maybe text) (Maybe Bool) |     StartElement tag [(tag, text)] |     EndElement tag |     CharacterData text |+    StartCData |+    EndCData |+    ProcessingInstruction text text |+    Comment text |     FailDocument XMLParseError     deriving (Eq, Show)  instance (NFData tag, NFData text) => NFData (SAXEvent tag text) where-    rnf (StartElement tag atts) = rnf (tag, atts)+    rnf (XMLDeclaration ver mEnc mSD) = rnf ver `seq` rnf mEnc `seq` rnf mSD+    rnf (StartElement tag atts) = rnf tag `seq` rnf atts     rnf (EndElement tag) = rnf tag     rnf (CharacterData text) = rnf text+    rnf StartCData = ()+    rnf EndCData = ()+    rnf (ProcessingInstruction target text) = rnf target `seq` rnf text+    rnf (Comment text) = rnf text     rnf (FailDocument err) = rnf err - -- | Converts a 'CString' to a 'GenericXMLString' type. textFromCString :: GenericXMLString text => CString -> IO text {-# INLINE textFromCString #-}@@ -191,7 +200,7 @@ -- | Lazily parse XML to SAX events. In the event of an error, FailDocument is -- the last element of the output list. parse :: (GenericXMLString tag, GenericXMLString text) =>-         ParseOptions tag text -- ^ Parser options+         ParseOptions tag text -- ^ Parse options       -> L.ByteString           -- ^ Input text (a lazy ByteString)       -> [SAXEvent tag text] parse opts input = unsafePerformIO $ do@@ -206,6 +215,17 @@             modifyIORef queueRef (CharacterData txt:)         Nothing -> return () +    setXMLDeclarationHandler parser $ \_ cVer cEnc cSd -> do+        ver <- textFromCString cVer+        mEnc <- if cEnc == nullPtr+            then return Nothing+            else Just <$> textFromCString cEnc+        let sd = if cSd < 0+                then Nothing+                else Just $ if cSd /= 0 then True else False+        modifyIORef queueRef (XMLDeclaration ver mEnc sd:)+        return True+     setStartElementHandler parser $ \_ cName cAttrs -> do         name <- textFromCString cName         attrs <- forM cAttrs $ \(cAttrName,cAttrValue) -> do@@ -224,6 +244,25 @@         txt <- gxFromCStringLen cText         modifyIORef queueRef (CharacterData txt:)         return True+        +    setStartCDataHandler parser $ \_  -> do+        modifyIORef queueRef (StartCData :)+        return True+        +    setEndCDataHandler parser $ \_  -> do+        modifyIORef queueRef (EndCData :)+        return True+        +    setProcessingInstructionHandler parser $ \_ cTarget cText -> do+        target <- textFromCString cTarget+        txt <- textFromCString cText+        modifyIORef queueRef (ProcessingInstruction target txt :)+        return True+        +    setCommentHandler parser $ \_ cText -> do+        txt <- textFromCString cText+        modifyIORef queueRef (Comment txt :)+        return True      let runParser inp = unsafeInterleaveIO $ do             rema <- withParser parser $ \pp -> case inp of@@ -266,7 +305,7 @@  -- | A variant of parseSAX that gives a document location with each SAX event. parseLocations :: (GenericXMLString tag, GenericXMLString text) =>-                  ParseOptions tag text  -- ^ Parser options+                  ParseOptions tag text  -- ^ Parse options                -> L.ByteString            -- ^ Input text (a lazy ByteString)                -> [(SAXEvent tag text, XMLParseLocation)] parseLocations opts input = unsafePerformIO $ do@@ -283,6 +322,18 @@             modifyIORef queueRef ((CharacterData txt, loc):)         Nothing -> return () +    setXMLDeclarationHandler parser $ \pp cVer cEnc cSd -> do+        ver <- textFromCString cVer+        mEnc <- if cEnc == nullPtr+            then return Nothing+            else Just <$> textFromCString cEnc+        let sd = if cSd < 0+                then Nothing+                else Just $ if cSd /= 0 then True else False+        loc <- getParseLocation pp+        modifyIORef queueRef ((XMLDeclaration ver mEnc sd,loc):)+        return True+     setStartElementHandler parser $ \pp cName cAttrs -> do         name <- textFromCString cName         attrs <- forM cAttrs $ \(cAttrName,cAttrValue) -> do@@ -304,6 +355,29 @@         loc <- getParseLocation pp         modifyIORef queueRef ((CharacterData txt, loc):)         return True+        +    setStartCDataHandler parser $ \pp -> do+        loc <- getParseLocation pp+        modifyIORef queueRef ((StartCData, loc):)+        return True+        +    setEndCDataHandler parser $ \pp -> do+        loc <- getParseLocation pp+        modifyIORef queueRef ((EndCData, loc):)+        return True+        +    setProcessingInstructionHandler parser $ \pp cTarget cText -> do+        target <- textFromCString cTarget+        txt <- textFromCString cText+        loc <- getParseLocation pp+        modifyIORef queueRef ((ProcessingInstruction target txt, loc) :)+        return True+        +    setCommentHandler parser $ \pp cText -> do+        txt <- textFromCString cText+        loc <- getParseLocation pp+        modifyIORef queueRef ((Comment txt, loc) :)+        return True      let runParser inp = unsafeInterleaveIO $ do             rema <- withParser parser $ \pp -> case inp of@@ -348,7 +422,7 @@ -- situations where it's not expected during normal operation, depending on the -- design of your program. parseThrowing :: (GenericXMLString tag, GenericXMLString text) =>-                 ParseOptions tag text  -- ^ Parser options+                 ParseOptions tag text  -- ^ Parse options               -> L.ByteString            -- ^ input text (a lazy ByteString)               -> [SAXEvent tag text] parseThrowing opts bs = map freakOut $ parse opts bs

@@ -122,8 +122,7 @@   parseThrowing,   XMLParseException(..), -  -- * SAX-style parse-  SAXEvent(..),+  -- * Convert from SAX   saxToTree,    -- * Abstraction of string types@@ -198,8 +197,11 @@ type instance ListOf (NodeG c tag text) = c (NodeG c tag text)  instance (Show tag, Show text) => Show (NodeG [] tag text) where-    show (Element na at ch) = "Element "++show na++" "++show at++" "++show ch-    show (Text t) = "Text "++show t+    showsPrec d (Element na at ch) = showParen (d > 10) $+        ("Element "++) . showsPrec 11 na . (" "++) .+                         showsPrec 11 at . (" "++) .+                         showsPrec 11 ch+    showsPrec d (Text t) = showParen (d > 10) $ ("Text "++) . showsPrec 11 t  instance (Eq tag, Eq text) => Eq (NodeG [] tag text) where     Element na1 at1 ch1 == Element na2 at2 ch2 =@@ -238,7 +240,7 @@ type UNodes text = Nodes text text {-# DEPRECATED UNodes "use [UNode text] instead" #-} --- | Type alias for a single node with unqualified tag names where tag and+-- | Type alias for a node with unqualified tag names where tag and -- text are the same string type. type UNode text = Node text text @@ -248,7 +250,7 @@ {-# DEPRECATED QNodes "use [QNode text] instead" #-} type QNodes text = [Node (QName text) text] --- | Type alias for a single node where qualified names are used for tags+-- | Type alias for a node where qualified names are used for tags type QNode text = Node (QName text) text  -- | DEPRECATED: Use [NNode text] instead.@@ -257,7 +259,7 @@ {-# DEPRECATED NNodes "use [NNode text] instead" #-} type NNodes text = [Node (NName text) text] --- | Type alias for a single node where namespaced names are used for tags+-- | Type alias for a node where namespaced names are used for tags type NNode text = Node (NName text) text  instance (Functor c, List c) => NodeClass NodeG c where@@ -269,13 +271,20 @@          isText (Text _) = True     isText _        = False-    ++    isCData _ = False+    isProcessingInstruction _ = False+    isComment _ = False+     isNamed _  (Text _) = False     isNamed nm (Element nm' _ _) = nm == nm'      getName (Text _)             = mempty     getName (Element name _ _)   = name +    hasTarget _ _ = False+    getTarget _ = mempty+     getAttributes (Text _)            = []     getAttributes (Element _ attrs _) = attrs @@ -314,7 +323,7 @@  -- | Strictly parse XML to tree. Returns error message or valid parsed tree. parse' :: (GenericXMLString tag, GenericXMLString text) =>-          ParseOptions tag text  -- ^ Parser options+          ParseOptions tag text  -- ^ Parse options        -> ByteString              -- ^ Input text (a strict ByteString)        -> Either XMLParseError (Node tag text) parse' opts doc = unsafePerformIO $ runParse where@@ -383,10 +392,11 @@           -> (Node tag text, Maybe XMLParseError) saxToTree events =     let (nodes, mError, _) = ptl events-    in  (safeHead nodes, mError)+    in  (findRoot nodes, mError)   where-    safeHead (a:_) = a-    safeHead [] = Element (gxFromString "") [] []+    findRoot (elt@(Element _ _ _ ):_) = elt+    findRoot (_:nodes) = findRoot nodes+    findRoot [] = Element (gxFromString "") [] []     ptl (StartElement name attrs:rema) =         let (children, err1, rema') = ptl rema             elt = Element name attrs children@@ -397,6 +407,7 @@         let (out, err, rema') = ptl rema         in  (Text txt:out, err, rema')     ptl (FailDocument err:_) = ([], Just err, [])+    ptl (_:rema) = ptl rema  -- extended node types not supported in this tree type     ptl [] = ([], Nothing, [])  @@ -404,7 +415,7 @@ -- will force the entire parse.  Therefore, to ensure lazy operation, don't -- check the error status until you have processed the tree. parse :: (GenericXMLString tag, GenericXMLString text) =>-         ParseOptions tag text   -- ^ Parser options+         ParseOptions tag text    -- ^ Parse options       -> L.ByteString             -- ^ Input text (a lazy ByteString)       -> (Node tag text, Maybe XMLParseError) parse opts bs = saxToTree $ SAX.parse opts bs@@ -431,7 +442,7 @@ -- situations where it's not expected during normal operation, depending on the -- design of your program. parseThrowing :: (GenericXMLString tag, GenericXMLString text) =>-         ParseOptions tag text -- ^ Parser options+         ParseOptions tag text -- ^ Parse options       -> L.ByteString           -- ^ Input text (a lazy ByteString)       -> Node tag text parseThrowing opts bs = fst $ saxToTree $ SAX.parseThrowing opts bs

@@ -1,6 +1,6 @@ Cabal-Version: >= 1.6 Name: hexpat-Version: 0.18.3+Version: 0.19 Synopsis: XML parser/formatter based on expat Description:   This package provides a general purpose Haskell XML library using Expat to@@ -10,8 +10,10 @@   .   Basic usage: Parsing a tree (/Tree/), formatting a tree (/Format/).   Other features: Helpers for processing XML trees (/Proc/), trees annotated with-  XML source location (/Annotated/), XML cursors (/Cursor/), SAX-style parse (/SAX/),-  and access to the low-level interface in case speed is paramount (/Internal.IO/).+  XML source location (/Annotated/), extended XML trees with comments,+  processing instructions, etc (/Extended/), XML cursors (/Cursor/),+  SAX-style parse (/SAX/), and access to the low-level interface in case speed+  is paramount (/Internal.IO/).   .   The design goals are speed, speed, speed, interface simplicity and modularity.   .@@ -25,10 +27,11 @@   I\/O is a better approach: Take a look at the /hexpat-iteratee/ package.   .   /IO/ is filed under /Internal/ because it's low-level and most users won't want-  it.  The other /Internal/ modules are re-exported by /Annotated/ and /Tree/,+  it.  The other /Internal/ modules are re-exported by /Annotated/, /Tree/ and /Extended/,   so you won't need to import them directly.   .   Credits to Iavor Diatchki and the @xml@ (XML.Light) package for /Proc/ and /Cursor/.+  Thanks to the many contributors.   .   INSTALLATION: Unix install requires an OS package called something like @libexpat-dev@.   On MacOSX, expat comes with Apple's optional X11 package, or you can install it from source.@@ -43,7 +46,7 @@     that seemed only to happen only on ghc6.12.X; 0.15.1 Fix broken Annotated parse;     0.16 switch from mtl to transformers; 0.17 fix mapNodeContainer & rename some things.;     0.18 rename defaultEncoding to overrideEncoding. 0.18.3 formatG and indent were demanding list-    items more than once (inefficient in chunked processing).+    items more than once (inefficient in chunked processing); 0.19 add Extended.hs. Category: XML License: BSD3 License-File: LICENSE@@ -52,7 +55,8 @@   Doug Beardsley,   Gregory Collins,   Evan Martin (who started the project),-  Matthew Pocock [drdozer]+  Matthew Pocock [drdozer],+  Kevin Jardine Maintainer: http://blacksapphire.com/antispam/ Copyright:   (c) 2009 Doug Beardsley <mightybyte@gmail.com>,@@ -60,7 +64,8 @@   (c) 2009 Gregory Collins,   (c) 2008 Evan Martin <martine@danga.com>,   (c) 2009 Matthew Pocock <matthew.pocock@ncl.ac.uk>,-  (c) 2007-2009 Galois Inc.+  (c) 2007-2009 Galois Inc.,+  (c) 2010 Kevin Jardine Homepage: http://haskell.org/haskellwiki/Hexpat/ Extra-Source-Files:   test/hexpat-tests.cabal,@@ -69,7 +74,8 @@   test/suite/Text/XML/Expat/Proc/Tests.hs,   test/suite/Text/XML/Expat/UnitTests.hs,   test/suite/Text/XML/Expat/Tests.hs,-  test/suite/Text/XML/Expat/Cursor/Tests.hs+  test/suite/Text/XML/Expat/Cursor/Tests.hs,+  test/suite/Text/XML/Expat/ParseFormat.hs Build-Type: Simple Stability: beta source-repository head@@ -90,6 +96,7 @@   Exposed-Modules:     Text.XML.Expat.Annotated,     Text.XML.Expat.Cursor,+    Text.XML.Expat.Extended,     Text.XML.Expat.Format,     Text.XML.Expat.IO,     Text.XML.Expat.Namespaced,@@ -98,6 +105,7 @@     Text.XML.Expat.Qualified,     Text.XML.Expat.SAX,     Text.XML.Expat.Tree,+    Text.XML.Expat.Internal.DocumentClass,     Text.XML.Expat.Internal.IO,     Text.XML.Expat.Internal.Namespaced,     Text.XML.Expat.Internal.NodeClass,

@@ -3,6 +3,7 @@ import qualified Text.XML.Expat.UnitTests import qualified Text.XML.Expat.Cursor.Tests import qualified Text.XML.Expat.Proc.Tests+import qualified Text.XML.Expat.ParseFormat  import Test.Framework (defaultMain, testGroup) @@ -14,4 +15,7 @@                             Text.XML.Expat.Proc.Tests.tests                 , testGroup "Text.XML.Expat.Cursor"                             Text.XML.Expat.Cursor.Tests.tests+                , testGroup "Text.XML.Expat.ParseFormat"+                            Text.XML.Expat.ParseFormat.tests                 ]+

@@ -0,0 +1,204 @@+{-# LANGUAGE OverloadedStrings, FlexibleContexts #-}+module Text.XML.Expat.ParseFormat where++import Text.XML.Expat.Extended+import Text.XML.Expat.Format+import qualified Text.XML.Expat.Tree as Tree+import qualified Text.XML.Expat.Annotated as Annotated++import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy.Char8 as L+import Data.List+import Data.Maybe+import Data.Monoid+import Data.Text (Text)+import Test.Framework.Providers.HUnit (hUnitTestToTests)+import Test.HUnit+++tests = hUnitTestToTests $+    TestList $ concatMap mkTests pfTests++pfTests :: [PFTest]+pfTests = [+        PFTest {+            pfName = "quotation",+            pfXML = "<test>\n" `mappend`+                    "<sample id=\"5\">This \"text with quotations\" should be escaped.</sample>\n" `mappend`+                    "<mytest>\n" `mappend`+                    "//<![CDATA[\n" `mappend`+                    "This \"text with quotations\" should not be escaped.\n" `mappend`+                    "Another line goes here.\n" `mappend`+                    "\n" `mappend`+                    "And more.\n" `mappend`+                    "//]]>\n" `mappend`+                    "</mytest>\n" `mappend`+                    "<?php somecode(); ?>\n" `mappend`+                    "<!-- this is a comment -->\n" `mappend`+                    "</test>",+            pfDoc = mkPlainDocument $+                Element "test" [] [+                    Text "\n",+                    Element "sample" [("id","5")] [Text "This \"text with quotations\" should be escaped."] (),+                    Text "\n",+                    Element "mytest" [] [+                        Text "\n",+                        Text "//",+                        CData "\nThis \"text with quotations\" should not be escaped.\nAnother line goes here.\n\nAnd more.\n//",+                        Text "\n"+                    ] (),+                    Text "\n",+                    Misc (ProcessingInstruction "php" "somecode(); "),+                    Text "\n",+                    Misc (Comment " this is a comment "),+                    Text "\n"+                ] (),+            pfOutXML = [(Extended,+                    "<test>\n" `mappend`+                    -- " gets translated into &quot; here but not inside CDATA.+                    "<sample id=\"5\">This &quot;text with quotations&quot; should be escaped.</sample>\n" `mappend`+                    "<mytest>\n" `mappend`+                    "//<![CDATA[\n" `mappend`+                    "This \"text with quotations\" should not be escaped.\n" `mappend`+                    "Another line goes here.\n" `mappend`+                    "\n" `mappend`+                    "And more.\n" `mappend`+                    "//]]>\n" `mappend`+                    "</mytest>\n" `mappend`+                    "<?php somecode(); ?>\n" `mappend`+                    "<!-- this is a comment -->\n" `mappend`+                    "</test>"                )],+            pfImpls = [Extended]+        },+        PFTest {+            pfName = "xmlDecl1",+            pfXML = "<?xml version=\"1.0\"?>\n<hello/>",+            pfDoc = Document (Just (XMLDeclaration "1.0" Nothing Nothing)) Nothing [] (Element "hello" [] [] ()),+            pfOutXML = [],+            pfImpls = [Extended]+        },+        PFTest {+            pfName = "xmlDecl2",+            pfXML = "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n<hello/>",+            pfDoc = Document (Just (XMLDeclaration "1.0" (Just "ISO-8859-1") Nothing)) Nothing [] (Element "hello" [] [] ()),+            pfOutXML = [],+            pfImpls = [Extended]+        },+        PFTest {+            pfName = "xmlDecl3",+            pfXML = "<?xml version=\"1.0\" standalone=\"yes\"?>\n<hello/>",+            pfDoc = Document (Just (XMLDeclaration "1.0" Nothing (Just True))) Nothing [] (Element "hello" [] [] ()),+            pfOutXML = [],+            pfImpls = [Extended]+        },+        PFTest {+            pfName = "xmlDecl4",+            pfXML = "<?xml version=\"1.0\" standalone=\"no\"?>\n<hello/>",+            pfDoc = Document (Just (XMLDeclaration "1.0" Nothing (Just False))) Nothing [] (Element "hello" [] [] ()),+            pfOutXML = [],+            pfImpls = [Extended]+        },+        PFTest {+            pfName = "topLevelMiscs1",+            pfXML = "<?xml version=\"1.0\"?>\n<?process My code?>\n<!-- And a comment -->\n<hello/>",+            pfDoc = Document (Just (XMLDeclaration "1.0" Nothing Nothing)) Nothing [+                    ProcessingInstruction "process" "My code",+                    Comment " And a comment "+                ] (Element "hello" [] [] ()),+            pfOutXML = [],+            pfImpls = [Extended]+        },+        PFTest {+            pfName = "topLevelMiscs2",+            -- Test that we can read processing instructions and comments from after the root element.+            pfXML = "<?xml version=\"1.0\"?>\n<?process My code?>\n<!-- And a comment -->\n" `mappend`+                    "<hello/>\n<!-- Also afterwards -->\n<?php something();?>",+            pfDoc = Document (Just (XMLDeclaration "1.0" Nothing Nothing)) Nothing [+                    ProcessingInstruction "process" "My code",+                    Comment " And a comment ",+                    Comment " Also afterwards ",+                    ProcessingInstruction "php" "something();"+                ] (Element "hello" [] [] ()),+            -- In the output they appear *before* the root element, however.+            pfOutXML = [(Extended,+                    "<?xml version=\"1.0\"?>\n<?process My code?>\n<!-- And a comment -->\n" `mappend`+                    "<!-- Also afterwards -->\n<?php something();?>\n<hello/>"+                )],+            pfImpls = [Extended]+        },+        PFTest {+            pfName = "basic",+            pfXML = "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n" `mappend`+                    "<second><test><test1 type=\"expression\">Cat &amp; mouse</test1>In between" `mappend`+                    "<test2 type=\"communication\" language=\"Rhyming slang\">Dog &amp; bone</test2>" `mappend`+                    "</test><test>Rose &amp; Crown</test></second>",+            pfDoc = Document (Just (XMLDeclaration "1.0" (Just "UTF-8") Nothing)) Nothing [] (+                 Element "second" [] [Element "test" [] [Element "test1" [("type","expression")]+                     [Text "Cat ",Text "&",Text " mouse"] (),Text "In between",+                      Element "test2" [("type","communication"),("language","Rhyming slang")]+                     [Text "Dog &",Text " bone"] ()] (),Element "test" []+                     [Text "Ro", Text "se & Crown"] ()] ()),  -- Test text normalization+            pfOutXML = [],+            pfImpls = [Tree, Annotated, Extended]+        }+    ]++-- | Recursively append all adjacent Text nodes.+normalizeText :: (NodeClass n [], Monoid text) => n [] tag text -> n [] tag text+normalizeText = modifyChildren combine+  where+    combine (t1:t2:ns) | isText t1 && isText t2 = combine ((mkText $ getText t1 `mappend` getText t2):ns)+    combine (e:ns) | isElement e = normalizeText e : combine ns+    combine (n:ns) = n:combine ns+    combine [] = []++mkTests :: PFTest -> [Test]+mkTests pf = flip concatMap (pfImpls pf) $ \impl ->+    case impl of+        Tree -> [+                TestLabel (pfName pf ++ "-tree") $ TestCase $ do+                    case Tree.parse' defaultParseOptions (pfXML pf) of+                        Left err -> assertFailure $ "parse failed: "++show err+                        Right root0 -> do+                            let root = normalizeText root0+                                sbDoc = normalizeText $ fromElement (getRoot $ pfDoc pf)+                            assertEqual "parse match" sbDoc (root :: Tree.UNode Text)+                            let sb = fromMaybe (pfXML pf) (impl `lookup` pfOutXML pf)+                                bs = formatTree' root+                            assertEqual "format match" sb bs+            ]+        Annotated -> [+                TestLabel (pfName pf ++ "-tree") $ TestCase $ do+                    case Annotated.parse' defaultParseOptions (pfXML pf) of+                        Left err -> assertFailure $ "parse failed: "++show err+                        Right root0 -> do+                            let root = normalizeText $ Annotated.mapAnnotation (const ()) root0+                                sbDoc = normalizeText $ fromElement (getRoot $ pfDoc pf)+                            assertEqual "parse match" sbDoc (root :: Annotated.UNode () Text)+                            let sb = fromMaybe (pfXML pf) (impl `lookup` pfOutXML pf)+                                bs = formatTree' root+                            assertEqual "format match" sb bs+            ]+        Extended  -> [+                TestLabel (pfName pf ++ "-extended") $ TestCase $ do+                    case parse' defaultParseOptions (pfXML pf) of+                        Left err -> assertFailure $ "parse failed: "++show err+                        Right doc0 -> do+                            let doc = modifyRoot normalizeText $ mapDocumentAnnotation (const ()) doc0+                            assertEqual "parse match" (modifyRoot normalizeText $ pfDoc pf) doc+                    let sb = fromMaybe (pfXML pf) (impl `lookup` pfOutXML pf)+                        bs = formatDocument' (pfDoc pf)+                    assertEqual "format match" sb bs+            ]++data Impl = Tree | Annotated | Extended deriving (Eq, Ord, Show)++data PFTest = PFTest {+        pfName   :: String,+        pfXML    :: ByteString,+        pfDoc    :: UDocument () Text,+        pfOutXML :: [(Impl, ByteString)],  -- ^ Output XML where it differs from the input XML+        pfImpls  :: [Impl]+    }+

@@ -225,6 +225,8 @@     "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n<test>Cat &amp; mouse</test>"   ] +data ParseFormatTest = ParseFormatTest {+    }  tests = hUnitTestToTests $     TestList [@@ -232,32 +234,32 @@             Tree.parse' :: ParseOptions String String                         -> B.ByteString                         -> Either XMLParseError (Node String String),-            formatTree),+            format),         t' ("ByteString",             Tree.parse' :: ParseOptions B.ByteString B.ByteString                         -> B.ByteString                         -> Either XMLParseError (Node B.ByteString B.ByteString),-            formatTree),+            format),         t' ("Text",             Tree.parse' :: ParseOptions T.Text T.Text                         -> B.ByteString                         -> Either XMLParseError (Node T.Text T.Text),-            formatTree),+            format),         t ("String/Lazy",             eitherify $ Tree.parse :: ParseOptions String String                                    -> L.ByteString                                    -> Either XMLParseError (Node String String),-            formatTree),+            format),         t ("ByteString/Lazy",             eitherify $ Tree.parse :: ParseOptions B.ByteString B.ByteString                                    -> L.ByteString                                    -> Either XMLParseError (Node B.ByteString B.ByteString),-            formatTree),+            format),         t ("Text/Lazy",             eitherify $ Tree.parse :: ParseOptions T.Text T.Text                                    -> L.ByteString                                    -> Either XMLParseError (Node T.Text T.Text),-            formatTree),+            format),         TestLabel "error1" $ TestCase $ test_error1,         TestLabel "error2" $ TestCase $ test_error2,         TestLabel "error3" $ TestCase $ test_error3,