diff --git a/Text/XML/Expat/Annotated.hs b/Text/XML/Expat/Annotated.hs --- a/Text/XML/Expat/Annotated.hs +++ b/Text/XML/Expat/Annotated.hs @@ -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 diff --git a/Text/XML/Expat/Extended.hs b/Text/XML/Expat/Extended.hs new file mode 100644 --- /dev/null +++ b/Text/XML/Expat/Extended.hs @@ -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 + 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 @@ -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 "\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 " 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 "')) $ - 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 " + cons(pack "]]>") $ + formatSAXGb l2 False + Cons (ProcessingInstruction target txt) l2 -> + cons (pack "") $ + formatSAXGb l2 cd + Cons (Comment txt) l2 -> + cons (pack "") $ + formatSAXGb l2 cd Cons (FailDocument _) l2 -> - formatSAXG l2 + formatSAXGb l2 cd pack :: String -> B.ByteString pack = B.pack . map c2w diff --git a/Text/XML/Expat/Internal/DocumentClass.hs b/Text/XML/Expat/Internal/DocumentClass.hs new file mode 100644 --- /dev/null +++ b/Text/XML/Expat/Internal/DocumentClass.hs @@ -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) + diff --git a/Text/XML/Expat/Internal/IO.hs b/Text/XML/Expat/Internal/IO.hs --- a/Text/XML/Expat/Internal/IO.hs +++ b/Text/XML/Expat/Internal/IO.hs @@ -1,12 +1,8 @@ {-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-} --- hexpat, a Haskell wrapper for expat --- Copyright (C) 2008 Evan Martin --- Copyright (C) 2009 Stephen Blackheath - -- | 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)))) diff --git a/Text/XML/Expat/Internal/NodeClass.hs b/Text/XML/Expat/Internal/NodeClass.hs --- a/Text/XML/Expat/Internal/NodeClass.hs +++ b/Text/XML/Expat/Internal/NodeClass.hs @@ -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. diff --git a/Text/XML/Expat/SAX.hs b/Text/XML/Expat/SAX.hs --- a/Text/XML/Expat/SAX.hs +++ b/Text/XML/Expat/SAX.hs @@ -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 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,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 diff --git a/hexpat.cabal b/hexpat.cabal --- a/hexpat.cabal +++ b/hexpat.cabal @@ -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 , @@ -60,7 +64,8 @@ (c) 2009 Gregory Collins, (c) 2008 Evan Martin , (c) 2009 Matthew Pocock , - (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, diff --git a/test/suite/TestSuite.hs b/test/suite/TestSuite.hs --- a/test/suite/TestSuite.hs +++ b/test/suite/TestSuite.hs @@ -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 ] + diff --git a/test/suite/Text/XML/Expat/ParseFormat.hs b/test/suite/Text/XML/Expat/ParseFormat.hs new file mode 100644 --- /dev/null +++ b/test/suite/Text/XML/Expat/ParseFormat.hs @@ -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 = "\n" `mappend` + "This \"text with quotations\" should be escaped.\n" `mappend` + "\n" `mappend` + "//\n" `mappend` + "\n" `mappend` + "\n" `mappend` + "\n" `mappend` + "", + 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, + "\n" `mappend` + -- " gets translated into " here but not inside CDATA. + "This "text with quotations" should be escaped.\n" `mappend` + "\n" `mappend` + "//\n" `mappend` + "\n" `mappend` + "\n" `mappend` + "\n" `mappend` + "" )], + pfImpls = [Extended] + }, + PFTest { + pfName = "xmlDecl1", + pfXML = "\n", + pfDoc = Document (Just (XMLDeclaration "1.0" Nothing Nothing)) Nothing [] (Element "hello" [] [] ()), + pfOutXML = [], + pfImpls = [Extended] + }, + PFTest { + pfName = "xmlDecl2", + pfXML = "\n", + pfDoc = Document (Just (XMLDeclaration "1.0" (Just "ISO-8859-1") Nothing)) Nothing [] (Element "hello" [] [] ()), + pfOutXML = [], + pfImpls = [Extended] + }, + PFTest { + pfName = "xmlDecl3", + pfXML = "\n", + pfDoc = Document (Just (XMLDeclaration "1.0" Nothing (Just True))) Nothing [] (Element "hello" [] [] ()), + pfOutXML = [], + pfImpls = [Extended] + }, + PFTest { + pfName = "xmlDecl4", + pfXML = "\n", + pfDoc = Document (Just (XMLDeclaration "1.0" Nothing (Just False))) Nothing [] (Element "hello" [] [] ()), + pfOutXML = [], + pfImpls = [Extended] + }, + PFTest { + pfName = "topLevelMiscs1", + pfXML = "\n\n\n", + 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 = "\n\n\n" `mappend` + "\n\n", + 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, + "\n\n\n" `mappend` + "\n\n" + )], + pfImpls = [Extended] + }, + PFTest { + pfName = "basic", + pfXML = "\n" `mappend` + "Cat & mouseIn between" `mappend` + "Dog & bone" `mappend` + "Rose & Crown", + 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] + } + diff --git a/test/suite/Text/XML/Expat/UnitTests.hs b/test/suite/Text/XML/Expat/UnitTests.hs --- a/test/suite/Text/XML/Expat/UnitTests.hs +++ b/test/suite/Text/XML/Expat/UnitTests.hs @@ -225,6 +225,8 @@ "\nCat & mouse" ] +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,