hexpat 0.10 → 0.11

raw patch · 22 files changed

+1472/−1023 lines, 22 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Text/XML/Expat/Annotated.hs +79/−48
• Text/XML/Expat/Cursor.hs +378/−0
• Text/XML/Expat/Format.hs +20/−5
• Text/XML/Expat/IO.hs +265/−99
• Text/XML/Expat/Namespaced.hs +5/−2
• Text/XML/Expat/Proc.hs +76/−0
• Text/XML/Expat/Qualified.hs +5/−2
• Text/XML/Expat/SAX.hs +409/−0
• Text/XML/Expat/Tree.hs +206/−238
• hexpat.cabal +29/−25
• test/Makefile +0/−28
• test/benchmark.hs +0/−84
• test/errorHandlingWay1.hs +0/−12
• test/errorHandlingWay2.hs +0/−16
• test/helloworld.hs +0/−33
• test/lazySAX.hs +0/−25
• test/lazyTree.hs +0/−25
• test/lazyTreeThrow.hs +0/−28
• test/leak.hs +0/−63
• test/locations.hs +0/−25
• test/test.xml +0/−101
• test/tests.hs +0/−164

@@ -9,61 +9,76 @@         -- * Tree structure         Node(..),         Attributes,  -- re-export from Tree-        Nodes,         UNode,-        UNodes,         UAttributes,         LNode,-        LNodes,         ULNode,-        ULNodes,         textContent,         unannotate,+         -- * Qualified nodes         QName(..),         QNode,-        QNodes,         QAttributes,         QLNode,-        QLNodes,+         -- * Namespaced nodes         NName (..),         NNode,-        NNodes,         NAttributes,         NLNode,-        NLNodes,         mkNName,         mkAnNName,         xmlnsUri,         xmlns,-        -- * Parse to tree++        -- * Deprecated parse functions+        parseSAX,+        parseSAXThrowing,+        parseSAXLocations,+        parseSAXLocationsThrowing,         parseTree,         parseTree',+        parseTreeThrowing,++        -- * Parse to tree         Encoding(..),         XMLParseError(..),         XMLParseLocation(..),+        parse,+        parse',+        parseThrowing,+         -- * SAX-style parse-        parseSAX,         SAXEvent(..),         saxToTree,-        parseSAXLocations,+         -- * Variants that throw exceptions         XMLParseException(..),-        parseTreeThrowing,-        parseSAXThrowing,-        parseSAXLocationsThrowing,         -- * Abstraction of string types         GenericXMLString(..)     ) where -import Text.XML.Expat.Tree hiding (Node(..), Nodes, UNode, UNodes, saxToTree,-    parseTree, parseTree', parseTreeThrowing, textContent)-import qualified Text.XML.Expat.Tree as Tree (Node(..))+import Text.XML.Expat.Tree ( Attributes, UAttributes )+import qualified Text.XML.Expat.Tree as Tree+import Text.XML.Expat.SAX ( Encoding(..)+                          , GenericXMLString(..)+                          , ParserOptions(..)+                          , SAXEvent(..)+                          , XMLParseError(..)+                          , XMLParseException(..)+                          , XMLParseLocation(..)+                          , parseSAX+                          , parseSAXThrowing+                          , parseSAXLocations+                          , parseSAXLocationsThrowing )++import qualified Text.XML.Expat.SAX as SAX import Text.XML.Expat.Qualified hiding (QNode, QNodes) import Text.XML.Expat.Namespaced hiding (NNode, NNodes)  import Control.Monad (mplus)+import Control.Parallel.Strategies import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import Data.Monoid@@ -80,6 +95,10 @@     Text !text     deriving (Eq, Show) +instance (NFData tag, NFData text, NFData a) => NFData (Node tag text a) where+    rnf (Element nam att chi ann) = rnf (nam, att, chi, ann)+    rnf (Text txt) = rnf txt+ unannotate :: Node tag text a -> Tree.Node tag text unannotate (Element na at ch _) = (Tree.Element na at (map unannotate ch)) unannotate (Text t) = Tree.Text t@@ -90,13 +109,6 @@ textContent (Element _ _ children _) = mconcat $ map textContent children textContent (Text txt) = txt --- | Type shortcut for annotated nodes-type Nodes tag text a = [Node tag text a]---- | Type shortcut for annotated nodes with unqualified tag names where tag and--- text are the same string type-type UNodes text a = Nodes text text a- -- | Type shortcut for a single annotated node with unqualified tag names where -- tag and text are the same string type type UNode text a = Node text text a@@ -104,35 +116,16 @@ -- | Type shortcut for a single annotated node, annotated with parse location type LNode tag text = Node tag text XMLParseLocation --- | Type shortcut for annotated nodes with location information.-type LNodes tag text = [Node tag text XMLParseLocation]- -- | Type shortcut for a single 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 shortcut for nodes with unqualified tag names where--- tag and text are the same string type, annotated with parse location-type ULNodes text = LNodes text text---- | Type shortcut for annotated nodes where qualified names are used for tags-type QNodes text a = Nodes (QName text) text a---- | Type shortcut for nodes where qualified names are used for tags, annotated with parse location-type QLNodes text = LNodes (QName text) text- -- | Type shortcut for a single annotated node where qualified names are used for tags type QNode text a = Node (QName text) text a  -- | Type shortcut for a single node where qualified names are used for tags, annotated with parse location type QLNode text = LNode (QName text) text --- | Type shortcut for annotated nodes where namespaced names are used for tags-type NNodes text a = Nodes (NName text) text a---- | Type shortcut for nodes where namespaced names are used for tags, annotated with parse location-type NLNodes text = LNodes (NName text) text- -- | Type shortcut for a single annotated node where namespaced names are used for tags type NNode text a = Node (NName text) text a @@ -169,25 +162,63 @@ -- | 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) =>+         ParserOptions tag text   -- ^ Optional encoding override+      -> L.ByteString             -- ^ Input text (a lazy ByteString)+      -> (LNode tag text, Maybe XMLParseError)+parse opts bs = saxToTree $ SAX.parseLocations opts bs++-- | DEPRECATED: Use 'parse' instead.+--+-- 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. parseTree :: (GenericXMLString tag, GenericXMLString text) =>              Maybe Encoding      -- ^ Optional encoding override           -> L.ByteString        -- ^ Input text (a lazy ByteString)           -> (LNode tag text, Maybe XMLParseError)-parseTree mEnc bs = saxToTree $ parseSAXLocations mEnc bs+{-# DEPRECATED parseTree "use Text.XML.Annotated.parse instead" #-}+parseTree mEnc = parse (ParserOptions mEnc Nothing)  -- | 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) =>+                 ParserOptions tag text   -- ^ Optional encoding override+              -> L.ByteString             -- ^ Input text (a lazy ByteString)+              -> LNode tag text+parseThrowing opts bs = fst $ saxToTree $ SAX.parseLocationsThrowing opts bs++-- | DEPRECATED: use 'parseThrowing' instead+--+-- Lazily parse XML to tree. In the event of an error, throw 'XMLParseException'. parseTreeThrowing :: (GenericXMLString tag, GenericXMLString text) =>              Maybe Encoding      -- ^ Optional encoding override           -> L.ByteString        -- ^ Input text (a lazy ByteString)           -> LNode tag text-parseTreeThrowing mEnc bs = fst $ saxToTree $ parseSAXLocationsThrowing mEnc bs+{-# DEPRECATED parseTreeThrowing "use Text.XML.Annotated.parseThrowing instead" #-}+parseTreeThrowing mEnc = parseThrowing (ParserOptions mEnc Nothing)  -- | Strictly parse XML to tree. Returns error message or valid parsed tree.+parse' :: (GenericXMLString tag, GenericXMLString text) =>+          ParserOptions tag text  -- ^ Optional encoding override+       -> B.ByteString            -- ^ Input text (a strict ByteString)+       -> Either XMLParseError (LNode tag text)+parse' opts bs = case parse opts (L.fromChunks [bs]) of+    (_, Just err)   -> Left err+    (root, Nothing) -> Right root ++-- | DEPRECATED: use 'parse' instead.+--+-- Strictly parse XML to tree. Returns error message or valid parsed tree. parseTree' :: (GenericXMLString tag, GenericXMLString text) =>               Maybe Encoding      -- ^ Optional encoding override            -> B.ByteString        -- ^ Input text (a strict ByteString)            -> Either XMLParseError (LNode tag text)-parseTree' mEnc bs = case parseTree mEnc (L.fromChunks [bs]) of-    (_, Just err)   -> Left err-    (root, Nothing) -> Right root +{-# DEPRECATED parseTree' "use Text.XML.Expat.parse' instead" #-}+parseTree' mEnc = parse' (ParserOptions mEnc Nothing) 

@@ -0,0 +1,378 @@+--------------------------------------------------------------------+-- |+-- Module    : Text.XML.Expat.Cursor+--+-- This module ported from Text.XML.Light.Proc+--+-- XML cursors for working XML content withing the context of+-- an XML document.  This implementation is based on the general+-- tree zipper written by Krasimir Angelov and Iavor S. Diatchki.+--++module Text.XML.Expat.Cursor+  ( Tag(..), getTag, fromTag+  , Cursor(..), Path++  -- * Conversions+  , fromTree+  , fromForest+  , toForest+  , toTree++  -- * Moving around+  , parent+  , root+  , getChild+  , firstChild+  , lastChild+  , left+  , right+  , nextDF++  -- ** Searching+  , findChild+  , findLeft+  , findRight+  , findRec++  -- * Node classification+  , isRoot+  , isFirst+  , isLast+  , isLeaf+  , isChild+  , hasChildren+  , getNodeIndex++  -- * Updates+  , setContent+  , modifyContent+  , modifyContentList+  , modifyContentM++  -- ** Inserting content+  , insertLeft+  , insertRight+  , insertManyLeft+  , insertManyRight+  , insertFirstChild+  , insertLastChild+  , insertManyFirstChild+  , insertManyLastChild+  , insertGoLeft+  , insertGoRight++  -- ** Removing content+  , removeLeft+  , removeRight+  , removeGoLeft+  , removeGoRight+  , removeGoUp++  ) where++import Text.XML.Expat.Tree+import Data.Maybe(isNothing)+import Control.Monad(mplus)++data Tag tag text = Tag { tagName    :: tag+                        , tagAttribs :: Attributes tag text+                        } deriving (Show)++{-+setTag :: Tag -> Element -> Element+setTag t e = fromTag t (elContent e)+-}++fromTag :: Tag tag text -> [Node tag text] -> Node tag text+fromTag t cs = Element { eName     = tagName t+                       , eAttrs    = tagAttribs t+                       , eChildren = cs+                       }++type Path tag text = [([Node tag text],Tag tag text,[Node tag text])]++-- | The position of a piece of content in an XML document.+data Cursor tag text = Cur+  { current :: Node tag text      -- ^ The currently selected content.+  , lefts   :: [Node tag text]    -- ^ Siblings on the left, closest first.+  , rights  :: [Node tag text]    -- ^ Siblings on the right, closest first.+  , parents :: Path tag text -- ^ The contexts of the parent elements of this location.+  } deriving (Show)++-- Moving around ---------------------------------------------------------------++-- | The parent of the given location.+parent :: Cursor tag text -> Maybe (Cursor tag text)+parent loc =+  case parents loc of+    (pls,v,prs) : ps -> Just+      Cur { current = (fromTag v+                    (combChildren (lefts loc) (current loc) (rights loc)))+          , lefts = pls, rights = prs, parents = ps+          }+    [] -> Nothing+++-- | The top-most parent of the given location.+root :: Cursor tag text -> Cursor tag text+root loc = maybe loc root (parent loc)++-- | The left sibling of the given location.+left :: Cursor tag text -> Maybe (Cursor tag text)+left loc =+  case lefts loc of+    t : ts -> Just loc { current = t, lefts = ts+                                    , rights = current loc : rights loc }+    []     -> Nothing++-- | The right sibling of the given location.+right :: Cursor tag text -> Maybe (Cursor tag text)+right loc =+  case rights loc of+    t : ts -> Just loc { current = t, lefts = current loc : lefts loc+                                    , rights = ts }+    []     -> Nothing++-- | The first child of the given location.+firstChild :: Cursor tag text -> Maybe (Cursor tag text)+firstChild loc =+  do (t : ts, ps) <- downParents loc+     return Cur { current = t, lefts = [], rights = ts , parents = ps }++-- | The last child of the given location.+lastChild :: Cursor tag text -> Maybe (Cursor tag text)+lastChild loc =+  do (ts, ps) <- downParents loc+     case reverse ts of+       l : ls -> return Cur { current = l, lefts = ls, rights = []+                                                     , parents = ps }+       [] -> Nothing++-- | Find the next left sibling that satisfies a predicate.+findLeft :: (Cursor tag text -> Bool) -> Cursor tag text -> Maybe (Cursor tag text)+findLeft p loc = do loc1 <- left loc+                    if p loc1 then return loc1 else findLeft p loc1++-- | Find the next right sibling that satisfies a predicate.+findRight :: (Cursor tag text -> Bool) -> Cursor tag text -> Maybe (Cursor tag text)+findRight p loc = do loc1 <- right loc+                     if p loc1 then return loc1 else findRight p loc1++-- | The first child that satisfies a predicate.+findChild :: (Cursor tag text -> Bool) -> Cursor tag text -> Maybe (Cursor tag text)+findChild p loc =+  do loc1 <- firstChild loc+     if p loc1 then return loc1 else findRight p loc1++-- | The next position in a left-to-right depth-first traversal of a document:+-- either the first child, right sibling, or the right sibling of a parent that+-- has one.+nextDF :: Cursor tag text -> Maybe (Cursor tag text)+nextDF c = firstChild c `mplus` up c+  where up x = right x `mplus` (up =<< parent x)++-- | Perform a depth first search for a descendant that satisfies the+-- given predicate.+findRec :: (Cursor tag text -> Bool) -> Cursor tag text -> Maybe (Cursor tag text)+findRec p c = if p c then Just c else findRec p =<< nextDF c+++-- | The child with the given index (starting from 0).+getChild :: Int -> Cursor tag text -> Maybe (Cursor tag text)+getChild n loc =+  do (ts,ps) <- downParents loc+     (ls,t,rs) <- splitChildren ts n+     return Cur { current = t, lefts = ls, rights = rs, parents = ps }+++-- | private: computes the parent for "down" operations.+downParents :: Cursor tag text -> Maybe ([Node tag text], Path tag text)+downParents loc =+  case current loc of+    Element n a c -> Just ( c+                      , (lefts loc, Tag n a, rights loc) : parents loc+                      )+    _      -> Nothing++getTag :: Node tag text -> Tag tag text+getTag e = Tag { tagName = eName e+               , tagAttribs = eAttrs e+               }+++-- Conversions -----------------------------------------------------------------++-- | A cursor for the given content.+fromTree :: Node tag text -> Cursor tag text+fromTree t = Cur { current = t, lefts = [], rights = [], parents = [] }++-- | The location of the first tree in a forest.+fromForest :: [Node tag text] -> Maybe (Cursor tag text)+fromForest (t:ts) = Just Cur { current = t, lefts = [], rights = ts+                                                      , parents = [] }+fromForest []     = Nothing++-- | Computes the tree containing this location.+toTree :: Cursor tag text -> Node tag text+toTree loc = current (root loc)++-- | Computes the forest containing this location.+toForest :: Cursor tag text -> [Node tag text]+toForest loc = let r = root loc in combChildren (lefts r) (current r) (rights r)+++-- Queries ---------------------------------------------------------------------++-- | Are we at the top of the document?+isRoot :: Cursor tag text -> Bool+isRoot loc = null (parents loc)++-- | Are we at the left end of the the document?+isFirst :: Cursor tag text -> Bool+isFirst loc = null (lefts loc)++-- | Are we at the right end of the document?+isLast :: Cursor tag text -> Bool+isLast loc = null (rights loc)++-- | Are we at the bottom of the document?+isLeaf :: Cursor tag text -> Bool+isLeaf loc = isNothing (downParents loc)++-- | Do we have a parent?+isChild :: Cursor tag text -> Bool+isChild loc = not (isRoot loc)++-- | Get the node index inside the sequence of children+getNodeIndex :: Cursor tag text -> Int+getNodeIndex loc = length (lefts loc)++-- | Do we have children?+hasChildren :: Cursor tag text -> Bool+hasChildren loc = not (isLeaf loc)++++-- Updates ---------------------------------------------------------------------++-- | Change the current content.+setContent :: Node tag text -> Cursor tag text -> Cursor tag text+setContent t loc = loc { current = t }++-- | Modify the current content.+modifyContent :: (Node tag text -> Node tag text) -> Cursor tag text -> Cursor tag text+modifyContent f loc = setContent (f (current loc)) loc++-- | Modify the current content.+modifyContentList :: (Node tag text -> [Node tag text]) -> Cursor tag text -> Maybe (Cursor tag text)+modifyContentList f loc = removeGoRight $ insertManyRight (f $ current loc) loc++-- | Modify the current content, allowing for an effect.+modifyContentM :: Monad m => (Node tag text -> m (Node tag text)) -> Cursor tag text -> m (Cursor tag text)+modifyContentM f loc = do x <- f (current loc)+                          return (setContent x loc)++-- | Insert content to the left of the current position.+insertLeft :: Node tag text -> Cursor tag text -> Cursor tag text+insertLeft t loc = loc { lefts = t : lefts loc }++-- | Insert content to the right of the current position.+insertRight :: Node tag text -> Cursor tag text -> Cursor tag text+insertRight t loc = loc { rights = t : rights loc }++-- | Insert content to the left of the current position.+insertManyLeft :: [Node tag text] -> Cursor tag text -> Cursor tag text+insertManyLeft t loc = loc { lefts = reverse t ++ lefts loc }++-- | Insert content to the right of the current position.+insertManyRight :: [Node tag text] -> Cursor tag text -> Cursor tag text+insertManyRight t loc = loc { rights = t ++ rights loc }++-- | Insert content as the first child of the current position.+mapChildren :: ([Node tag text] -> [Node tag text])+            -> Cursor tag text+            -> Maybe (Cursor tag text)+mapChildren f loc = let e = current loc in+  case e of+    Text _ -> Nothing+    Element _ _ c -> Just $ loc { current = e { eChildren = f c } }++-- | Insert content as the first child of the current position.+insertFirstChild :: Node tag text -> Cursor tag text -> Maybe (Cursor tag text)+insertFirstChild t = mapChildren (t:)++-- | Insert content as the first child of the current position.+insertLastChild :: Node tag text -> Cursor tag text -> Maybe (Cursor tag text)+insertLastChild t = mapChildren (++[t])++-- | Insert content as the first child of the current position.+insertManyFirstChild :: [Node tag text] -> Cursor tag text -> Maybe (Cursor tag text)+insertManyFirstChild t = mapChildren (t++)++-- | Insert content as the first child of the current position.+insertManyLastChild :: [Node tag text] -> Cursor tag text -> Maybe (Cursor tag text)+insertManyLastChild t = mapChildren (++t)++-- | Remove the content on the left of the current position, if any.+removeLeft :: Cursor tag text -> Maybe (Node tag text,Cursor tag text)+removeLeft loc = case lefts loc of+                   l : ls -> return (l,loc { lefts = ls })+                   [] -> Nothing++-- | Remove the content on the right of the current position, if any.+removeRight :: Cursor tag text -> Maybe (Node tag text,Cursor tag text)+removeRight loc = case rights loc of+                    l : ls -> return (l,loc { rights = ls })+                    [] -> Nothing+++-- | Insert content to the left of the current position.+-- The new content becomes the current position.+insertGoLeft :: Node tag text -> Cursor tag text -> Cursor tag text+insertGoLeft t loc = loc { current = t, rights = current loc : rights loc }++-- | Insert content to the right of the current position.+-- The new content becomes the current position.+insertGoRight :: Node tag text -> Cursor tag text -> Cursor tag text+insertGoRight t loc = loc { current = t, lefts = current loc : lefts loc }++-- | Remove the current element.+-- The new position is the one on the left.+removeGoLeft :: Cursor tag text -> Maybe (Cursor tag text)+removeGoLeft loc = case lefts loc of+                     l : ls -> Just loc { current = l, lefts = ls }+                     []     -> Nothing++-- | Remove the current element.+-- The new position is the one on the right.+removeGoRight :: Cursor tag text -> Maybe (Cursor tag text)+removeGoRight loc = case rights loc of+                     l : ls -> Just loc { current = l, rights = ls }+                     []     -> Nothing++-- | Remove the current element.+-- The new position is the parent of the old position.+removeGoUp :: Cursor tag text -> Maybe (Cursor tag text)+removeGoUp loc =+  case parents loc of+    (pls,v,prs) : ps -> Just+      Cur { current = fromTag v (reverse (lefts loc) ++ rights loc)+          , lefts = pls, rights = prs, parents = ps+          }+    [] -> Nothing+++-- | private: Gets the given element of a list.+-- Also returns the preceding elements (reversed) and the following elements.+splitChildren :: [a] -> Int -> Maybe ([a],a,[a])+splitChildren _ n | n < 0 = Nothing+splitChildren cs pos = loop [] cs pos+  where loop acc (x:xs) 0 = Just (acc,x,xs)+        loop acc (x:xs) n = loop (x:acc) xs $! n-1+        loop _ _ _        = Nothing++-- | private: combChildren ls x ys = reverse ls ++ [x] ++ ys+combChildren :: [a] -> a -> [a] -> [a]+combChildren ls t rs = foldl (flip (:)) (t:rs) ls+

@@ -9,10 +9,13 @@  module Text.XML.Expat.Format (         -- * High level-        formatTree,-        formatTree',+        format,+        format',         formatNode,         formatNode',+        -- * Deprecated names+        formatTree,+        formatTree',         -- * Low level         xmlHeader,         treeToSAX,@@ -29,17 +32,29 @@ import qualified Data.Text.Encoding as TE import Data.Word --- | Format document with <?xml.. header - lazy variant that returns lazy ByteString.+-- | DEPRECATED: Renamed to 'format'. formatTree :: (GenericXMLString tag, GenericXMLString text) =>               Node tag text            -> L.ByteString-formatTree node = xmlHeader `L.append` formatNode node+formatTree = format --- | Format document with <?xml.. header - strict variant that returns strict ByteString.+-- | Format document with <?xml.. header - lazy variant that returns lazy ByteString.+format :: (GenericXMLString tag, GenericXMLString text) =>+              Node tag text+           -> L.ByteString+format node = xmlHeader `L.append` formatNode node++-- | DEPRECATED: Renamed to 'format''. formatTree' :: (GenericXMLString tag, GenericXMLString text) =>                Node tag text             -> B.ByteString formatTree' = B.concat . L.toChunks . formatTree++-- | Format document with <?xml.. header - strict variant that returns strict ByteString.+format' :: (GenericXMLString tag, GenericXMLString text) =>+               Node tag text+            -> B.ByteString+format' = B.concat . L.toChunks . formatTree  -- | Format XML node with no header - lazy variant that returns lazy ByteString. formatNode :: (GenericXMLString tag, GenericXMLString text) =>

@@ -4,9 +4,9 @@ -- 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 interface provided by "Text-XML-Expat-Tree".--- Basic usage is:+-- | 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: -- -- (1) Make a new parser: 'newParser'. --@@ -24,10 +24,20 @@   XMLParseLocation(..),    -- ** Parser Callbacks-  StartElementHandler, EndElementHandler, CharacterDataHandler,-  setStartElementHandler, setEndElementHandler, setCharacterDataHandler,+  StartElementHandler,+  EndElementHandler,+  CharacterDataHandler,+  ExternalEntityRefHandler,+  SkippedEntityHandler,+  setStartElementHandler,+  setEndElementHandler,+  setCharacterDataHandler,+  setExternalEntityRefHandler,+  setSkippedEntityHandler,+  setUseForeignDTD,    -- ** Lower-level interface+  parseExternalEntityReference,   unsafeParseChunk,   withHandlers,   unsafeSetHandlers,@@ -44,8 +54,8 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Internal as BSI+import Data.Maybe (maybe) import Data.IORef-import Data.Int import Foreign import CForeign @@ -53,16 +63,19 @@ -- |Opaque parser type. type ParserPtr = Ptr () data Parser = Parser-    (ForeignPtr ())-    (IORef CStartElementHandler)-    (IORef CEndElementHandler)-    (IORef CCharacterDataHandler)+    { _parserObj                :: ForeignPtr ()+    , _startElementHandler      :: IORef CStartElementHandler+    , _endElementHandler        :: IORef CEndElementHandler+    , _cdataHandler             :: IORef CCharacterDataHandler+    , _externalEntityRefHandler :: IORef (Maybe CExternalEntityRefHandler)+    , _skippedEntityHandler     :: IORef (Maybe CSkippedEntityHandler)+    }  instance Show Parser where-    showsPrec _ (Parser fp _ _ _) = showsPrec 0 fp+    showsPrec _ (Parser fp _ _ _ _ _) = showsPrec 0 fp  withParser :: Parser -> (ParserPtr -> IO a) -> IO a-withParser (Parser fp _ _ _) = withForeignPtr fp+withParser (Parser fp _ _ _ _ _) = withForeignPtr fp  -- |Encoding types available for the document encoding. data Encoding = ASCII | UTF8 | UTF16 | ISO88591@@ -76,25 +89,33 @@ withOptEncoding Nothing    f = f nullPtr withOptEncoding (Just enc) f = withCString (encodingToString enc) f + parserCreate :: Maybe Encoding -> IO (ParserPtr) parserCreate a1 =   withOptEncoding a1 $ \a1' ->   parserCreate'_ a1' >>= \res ->   let {res' = id res} in   return (res')-foreign import ccall "&XML_ParserFree" parserFree :: FunPtr (ParserPtr -> IO ()) --- |Create a 'Parser'.  The encoding parameter, if provided, overrides the--- document's encoding declaration.+-- | Create a 'Parser'. newParser :: Maybe Encoding -> IO Parser newParser enc = do-  ptr <- parserCreate enc-  fptr <- newForeignPtr parserFree ptr+  ptr        <- parserCreate enc+  fptr       <- newForeignPtr parserFree ptr   nullStartH <- newIORef nullCStartElementHandler-  nullEndH <- newIORef nullCEndElementHandler-  nullCharH <- newIORef nullCCharacterDataHandler-  return $ Parser fptr nullStartH nullEndH nullCharH+  nullEndH   <- newIORef nullCEndElementHandler+  nullCharH  <- newIORef nullCCharacterDataHandler+  extH       <- newIORef Nothing+  skipH      <- newIORef Nothing ++  return $ Parser fptr nullStartH nullEndH nullCharH extH skipH++setUseForeignDTD :: Parser -> Bool -> IO ()+setUseForeignDTD p b = withParser p $ \p' -> xmlUseForeignDTD p' b'+  where+    b' = if b then 1 else 0+ -- ByteString.useAsCStringLen is almost what we need, but C2HS wants a CInt -- instead of an Int. withBStringLen :: BS.ByteString -> ((CString, CInt) -> IO a) -> IO a@@ -105,10 +126,10 @@ unStatus 0 = False unStatus _ = True --- |@parse data@ feeds /lazy/ ByteString data into a 'Parser'. It returns Nothing--- on success, or Just the parse error.+-- |@parse data@ feeds /lazy/ ByteString data into a 'Parser'. It returns+-- Nothing on success, or Just the parse error. parse :: Parser -> BSL.ByteString -> IO (Maybe XMLParseError)-parse parser@(Parser _ _ _ _) bs = withHandlers parser $ do+parse parser bs = withHandlers parser $ do     ok <- doParseChunks (BSL.toChunks bs)     if ok         then return Nothing@@ -121,10 +142,10 @@             then doParseChunks cs             else return False --- |@parse data@ feeds /strict/ ByteString data into a 'Parser'. It returns Nothing--- on success, or Just the parse error.+-- |@parse data@ feeds /strict/ ByteString data into a 'Parser'. It returns+-- Nothing on success, or Just the parse error. parse' :: Parser -> BS.ByteString -> IO (Maybe XMLParseError)-parse' parser@(Parser _ _ _ _) bs = withHandlers parser $ do+parse' parser bs = withHandlers parser $ do     ok <- doParseChunk parser bs True     if ok         then return Nothing@@ -139,9 +160,23 @@            -> IO (Maybe XMLParseError) parseChunk parser xml final = withHandlers parser $ unsafeParseChunk parser xml final --- | This variant of 'parseChunk' must either be called inside 'withHandlers' (safest), or--- between 'unsafeSetHandlers' and 'unsafeReleaseHandlers', and this--- will give you better performance than 'parseChunk' if you process multiple chunks inside.+parseExternalEntityReference :: Parser+                             -> CString         -- ^ context+                             -> Maybe Encoding  -- ^ encoding+                             -> CStringLen      -- ^ text+                             -> IO Bool+parseExternalEntityReference parser context encoding (text,sz) =+    withParser parser $ \p -> do+        extp <- withOptEncoding encoding $+                xmlExternalEntityParserCreate p context+        e <- doParseChunk'_ extp text (fromIntegral sz) 1+        parserFree' extp+        return $ e == 1++-- | This variant of 'parseChunk' must either be called inside 'withHandlers'+-- (safest), or between 'unsafeSetHandlers' and 'unsafeReleaseHandlers', and+-- this will give you better performance than 'parseChunk' if you process+-- multiple chunks inside. unsafeParseChunk :: Parser            -> BS.ByteString            -> Bool@@ -152,6 +187,7 @@         then return Nothing         else Just `fmap` getError parser +getError :: Parser -> IO XMLParseError getError parser = withParser parser $ \p -> do     code <- xmlGetErrorCode p     cerr <- xmlErrorString code@@ -163,23 +199,43 @@     (FunPtr CStartElementHandler)     (FunPtr CEndElementHandler)     (FunPtr CCharacterDataHandler)+    (Maybe (FunPtr CExternalEntityRefHandler))+    (Maybe (FunPtr CSkippedEntityHandler))  unsafeSetHandlers :: Parser -> IO ExpatHandlers-unsafeSetHandlers parser@(Parser fp startRef endRef charRef) = do+unsafeSetHandlers parser@(Parser _ startRef endRef charRef extRef skipRef) =+  do     cStartH <- mkCStartElementHandler =<< readIORef startRef     cEndH   <- mkCEndElementHandler =<< readIORef endRef     cCharH  <- mkCCharacterDataHandler =<< readIORef charRef+    mExtH   <- readIORef extRef >>=+                   maybe (return Nothing)+                         (\h -> liftM Just $ mkCExternalEntityRefHandler h)++    mSkipH  <- readIORef skipRef >>=+                   maybe (return Nothing)+                         (\h -> liftM Just $ mkCSkippedEntityHandler h)+     withParser parser $ \p -> do         xmlSetstartelementhandler  p cStartH         xmlSetendelementhandler    p cEndH         xmlSetcharacterdatahandler p cCharH-    return $ ExpatHandlers cStartH cEndH cCharH+        maybe (return ())+              (xmlSetExternalEntityRefHandler p)+              mExtH+        maybe (return ())+              (xmlSetSkippedEntityHandler p)+              mSkipH +    return $ ExpatHandlers cStartH cEndH cCharH mExtH mSkipH+ unsafeReleaseHandlers :: ExpatHandlers -> IO ()-unsafeReleaseHandlers (ExpatHandlers cStartH cEndH cCharH) = do+unsafeReleaseHandlers (ExpatHandlers cStartH cEndH cCharH mcExtH mcSkipH) = do     freeHaskellFunPtr cStartH     freeHaskellFunPtr cEndH     freeHaskellFunPtr cCharH+    maybe (return ()) freeHaskellFunPtr mcExtH+    maybe (return ()) freeHaskellFunPtr mcSkipH  -- | 'unsafeParseChunk' is required to be called inside @withHandlers@. -- Safer than using 'unsafeSetHandlers' / 'unsafeReleaseHandlers'.@@ -224,6 +280,7 @@ instance NFData XMLParseLocation where     rnf (XMLParseLocation lin col ind cou) = rnf (lin, col, ind, cou) +getParseLocation :: Parser -> IO XMLParseLocation getParseLocation parser = withParser parser $ \p -> do     line <- xmlGetCurrentLineNumber p     col <- xmlGetCurrentColumnNumber p@@ -236,123 +293,114 @@             xmlByteCount = fromIntegral count         } --- |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.+-- | 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. type StartElementHandler  = CString -> [(CString, CString)] -> IO Bool--- |The type of the \"element ended\" callback.  The parameter is--- the element name. Return True to continue parsing as normal, or False to--- terminate the parse.++-- | The type of the \"element ended\" callback.  The parameter is the element+-- name. Return True to continue parsing as normal, or False to terminate the+-- parse. type EndElementHandler    = CString -> IO Bool--- |The type of the \"character data\" callback.  The parameter is--- the character data processed.  This callback may be called more than once--- while processing a single conceptual block of text. Return True to continue++-- | The type of the \"character data\" callback.  The parameter is the+-- character data processed.  This callback may be called more than once while+-- processing a single conceptual block of text. Return True to continue -- parsing as normal, or False to terminate the parse. type CharacterDataHandler = CStringLen -> IO Bool -type CStartElementHandler = Ptr () -> CString -> Ptr CString -> IO ()-nullCStartElementHandler _ _ _ = return ()+-- | The type of the \"external entity reference\" callback. See the expat+-- documentation.+type ExternalEntityRefHandler =  Parser+                              -> CString   -- context+                              -> CString   -- base+                              -> CString   -- systemID+                              -> CString   -- publicID+                              -> IO Bool --- Note on word sizes:------ on expat 2.0:--- XML_GetCurrentLineNumber returns XML_Size--- XML_GetCurrentColumnNumber returns XML_Size--- XML_GetCurrentByteIndex returns XML_Index--- These are defined in expat_external.h------ debian-i386 says XML_Size and XML_Index are 4 bytes.--- ubuntu-amd64 says XML_Size and XML_Index are 8 bytes.--- These two systems do NOT define XML_LARGE_SIZE, which would force these types--- to be 64-bit.+-- | Set a skipped entity handler. This is called in two situations: ----- If we guess the word size too small, it shouldn't matter: We will just discard--- the most significant part.  If we get the word size too large, we will get--- garbage (very bad).+-- 1. An entity reference is encountered for which no declaration has been read+-- and this is not an error. ----- So - what I will do is use CLong and CULong, which correspond to what expat--- is using when XML_LARGE_SIZE is disabled, and give the correct sizes on the--- two machines mentioned above.  At the absolute worst the word size will be too--- short.+-- 2. An internal entity reference is read, but not expanded, because+-- @XML_SetDefaultHandler@ has been called.+type SkippedEntityHandler =  CString  -- entityName+                          -> Int      -- is a parameter entity?+                          -> IO Bool -foreign import ccall unsafe "expat.h XML_GetErrorCode" xmlGetErrorCode-    :: ParserPtr -> IO CInt-foreign import ccall unsafe "expat.h XML_GetCurrentLineNumber" xmlGetCurrentLineNumber-    :: ParserPtr -> IO CULong-foreign import ccall unsafe "expat.h XML_GetCurrentColumnNumber" xmlGetCurrentColumnNumber-    :: ParserPtr -> IO CULong-foreign import ccall unsafe "expat.h XML_GetCurrentByteIndex" xmlGetCurrentByteIndex-    :: ParserPtr -> IO CLong-foreign import ccall unsafe "expat.h XML_GetCurrentByteCount" xmlGetCurrentByteCount-    :: ParserPtr -> IO CInt-foreign import ccall unsafe "expat.h XML_ErrorString" xmlErrorString-    :: CInt -> IO CString-foreign import ccall unsafe "expat.h XML_StopParser" xmlStopParser-    :: ParserPtr -> CInt -> IO ()+type CStartElementHandler = Ptr () -> CString -> Ptr CString -> IO () +nullCStartElementHandler :: CStartElementHandler+nullCStartElementHandler _ _ _ = return ()+ foreign import ccall safe "wrapper"   mkCStartElementHandler :: CStartElementHandler                          -> IO (FunPtr CStartElementHandler)  wrapStartElementHandler :: Parser -> StartElementHandler -> CStartElementHandler-wrapStartElementHandler parser@(Parser _ _ _ _) handler = h+wrapStartElementHandler parser handler = h   where-    h ptr cname cattrs = do+    h _ cname cattrs = do         cattrlist <- peekArray0 nullPtr cattrs         stillRunning <- handler cname (pairwise cattrlist)-        unless stillRunning $-            withParser parser $ \p -> xmlStopParser p 0+        unless stillRunning $ stopParser parser --- |Attach a StartElementHandler to a Parser.+-- | Attach a StartElementHandler to a Parser. setStartElementHandler :: Parser -> StartElementHandler -> IO ()-setStartElementHandler parser@(Parser _ startRef _ _) handler =-    withParser parser $ \p -> do-        writeIORef startRef $ wrapStartElementHandler parser handler+setStartElementHandler parser@(Parser _ startRef _ _ _ _) handler =+    writeIORef startRef $ wrapStartElementHandler parser handler  type CEndElementHandler = Ptr () -> CString -> IO ()++nullCEndElementHandler :: CEndElementHandler nullCEndElementHandler _ _ = return ()  foreign import ccall safe "wrapper"   mkCEndElementHandler :: CEndElementHandler                        -> IO (FunPtr CEndElementHandler) wrapEndElementHandler :: Parser -> EndElementHandler -> CEndElementHandler-wrapEndElementHandler parser@(Parser _ _ _ _) handler = h+wrapEndElementHandler parser handler = h   where-    h ptr cname = do+    h _ cname = do         stillRunning <- handler cname-        unless stillRunning $-            withParser parser $ \p -> xmlStopParser p 0+        unless stillRunning $ stopParser parser --- |Attach an EndElementHandler to a Parser.+-- | Attach an EndElementHandler to a Parser. setEndElementHandler :: Parser -> EndElementHandler -> IO ()-setEndElementHandler parser@(Parser _ _ endRef _) handler =-    withParser parser $ \p -> do-        writeIORef endRef $ wrapEndElementHandler parser handler+setEndElementHandler parser@(Parser _ _ endRef _ _ _) handler =+    writeIORef endRef $ wrapEndElementHandler parser handler  type CCharacterDataHandler = Ptr () -> CString -> CInt -> IO ()++nullCCharacterDataHandler :: CCharacterDataHandler nullCCharacterDataHandler _ _ _ = return ()  foreign import ccall safe "wrapper"   mkCCharacterDataHandler :: CCharacterDataHandler                           -> IO (FunPtr CCharacterDataHandler) wrapCharacterDataHandler :: Parser -> CharacterDataHandler -> CCharacterDataHandler-wrapCharacterDataHandler parser@(Parser _ _ _ _) handler = h+wrapCharacterDataHandler parser handler = h   where-    h ptr cdata len = do+    h _ cdata len = do         stillRunning <- handler (cdata, fromIntegral len)-        unless stillRunning $-            withParser parser $ \p -> xmlStopParser p 0+        unless stillRunning $ stopParser parser  -- | Attach an CharacterDataHandler to a Parser. setCharacterDataHandler :: Parser -> CharacterDataHandler -> IO ()-setCharacterDataHandler parser@(Parser _ _ _ charRef) handler =-    withParser parser $ \p -> do-        writeIORef charRef $ wrapCharacterDataHandler parser handler+setCharacterDataHandler parser@(Parser _ _ _ charRef _ _) handler =+    writeIORef charRef $ wrapCharacterDataHandler parser handler +pairwise :: [a] -> [(a,a)] pairwise (x1:x2:xs) = (x1,x2) : pairwise xs pairwise _          = [] +stopParser :: Parser -> IO ()+stopParser parser = withParser parser $ \p -> xmlStopParser p 0 +------------------------------------------------------------------------------+-- C imports+ foreign import ccall unsafe "XML_ParserCreate"   parserCreate'_ :: ((Ptr CChar) -> (IO (Ptr ()))) @@ -367,3 +415,121 @@  foreign import ccall safe "XML_Parse"   doParseChunk'_ :: ((Ptr ()) -> ((Ptr CChar) -> (CInt -> (CInt -> (IO CInt)))))++foreign import ccall unsafe "XML_UseForeignDTD"+  xmlUseForeignDTD :: ParserPtr     -- ^ parser+                   -> CChar         -- ^ use foreign DTD? (external entity ref+                                    -- handler will be called with publicID &+                                    -- systemID set to null+                   -> IO ()++foreign import ccall "&XML_ParserFree" parserFree :: FunPtr (ParserPtr -> IO ())+foreign import ccall "XML_ParserFree" parserFree' :: ParserPtr -> IO ()++type CExternalEntityRefHandler = ParserPtr   -- parser+                              -> Ptr CChar   -- context+                              -> Ptr CChar   -- base+                              -> Ptr CChar   -- systemID+                              -> Ptr CChar   -- publicID+                              -> IO ()++foreign import ccall safe "wrapper"+  mkCExternalEntityRefHandler :: CExternalEntityRefHandler+                              -> IO (FunPtr CExternalEntityRefHandler)+++foreign import ccall unsafe "XML_SetExternalEntityRefHandler"+  xmlSetExternalEntityRefHandler :: ParserPtr+                                 -> FunPtr CExternalEntityRefHandler+                                 -> IO ()++foreign import ccall unsafe "XML_SetSkippedEntityHandler"+  xmlSetSkippedEntityHandler :: ParserPtr+                             -> FunPtr CSkippedEntityHandler+                             -> IO ()++foreign import ccall unsafe "XML_ExternalEntityParserCreate"+  xmlExternalEntityParserCreate :: ParserPtr+                                -> CString   -- ^ context+                                -> CString   -- ^ encoding+                                -> IO ParserPtr++type CSkippedEntityHandler =  Ptr ()   -- user data pointer+                           -> CString  -- entity name+                           -> CInt     -- is a parameter entity?+                           -> IO ()++foreign import ccall safe "wrapper"+  mkCSkippedEntityHandler :: CSkippedEntityHandler+                          -> IO (FunPtr CSkippedEntityHandler)+++wrapExternalEntityRefHandler :: Parser+                             -> ExternalEntityRefHandler+                             -> CExternalEntityRefHandler+wrapExternalEntityRefHandler parser handler = h+  where+    h _ context base systemID publicID = do+        stillRunning <- handler parser context base systemID publicID+        unless stillRunning $ stopParser parser+++wrapSkippedEntityHandler :: Parser+                         -> SkippedEntityHandler+                         -> CSkippedEntityHandler+wrapSkippedEntityHandler parser handler = h+  where+    h _ entityName i = do+        stillRunning <- handler entityName (fromIntegral i)+        unless stillRunning $ stopParser parser+++setExternalEntityRefHandler :: Parser -> ExternalEntityRefHandler -> IO ()+setExternalEntityRefHandler parser h =+    writeIORef ref $ Just $ wrapExternalEntityRefHandler parser h+  where+    ref = _externalEntityRefHandler parser++setSkippedEntityHandler :: Parser -> SkippedEntityHandler -> IO ()+setSkippedEntityHandler parser h =+    writeIORef ref $ Just $ wrapSkippedEntityHandler parser h+  where+    ref = _skippedEntityHandler parser++-- Note on word sizes:+--+-- on expat 2.0:+-- XML_GetCurrentLineNumber returns XML_Size+-- XML_GetCurrentColumnNumber returns XML_Size+-- XML_GetCurrentByteIndex returns XML_Index+-- These are defined in expat_external.h+--+-- debian-i386 says XML_Size and XML_Index are 4 bytes.+-- ubuntu-amd64 says XML_Size and XML_Index are 8 bytes.+-- These two systems do NOT define XML_LARGE_SIZE, which would force these types+-- to be 64-bit.+--+-- If we guess the word size too small, it shouldn't matter: We will just discard+-- the most significant part.  If we get the word size too large, we will get+-- garbage (very bad).+--+-- So - what I will do is use CLong and CULong, which correspond to what expat+-- is using when XML_LARGE_SIZE is disabled, and give the correct sizes on the+-- two machines mentioned above.  At the absolute worst the word size will be too+-- short.++foreign import ccall unsafe "expat.h XML_GetErrorCode" xmlGetErrorCode+    :: ParserPtr -> IO CInt+foreign import ccall unsafe "expat.h XML_GetCurrentLineNumber" xmlGetCurrentLineNumber+    :: ParserPtr -> IO CULong+foreign import ccall unsafe "expat.h XML_GetCurrentColumnNumber" xmlGetCurrentColumnNumber+    :: ParserPtr -> IO CULong+foreign import ccall unsafe "expat.h XML_GetCurrentByteIndex" xmlGetCurrentByteIndex+    :: ParserPtr -> IO CLong+foreign import ccall unsafe "expat.h XML_GetCurrentByteCount" xmlGetCurrentByteCount+    :: ParserPtr -> IO CInt+foreign import ccall unsafe "expat.h XML_ErrorString" xmlErrorString+    :: CInt -> IO CString+foreign import ccall unsafe "expat.h XML_StopParser" xmlStopParser+    :: ParserPtr -> CInt -> IO ()+

@@ -35,8 +35,11 @@ instance NFData text => NFData (NName text) where     rnf (NName ns loc) = rnf (ns, loc) --- | Type shortcut for nodes where namespaced names are used for tags-type NNodes text = Nodes (NName text) text+-- | DEPRECATED: Use [NNode text] instead.+--+-- Type shortcut for nodes where namespaced names are used for tags.+{-# DEPRECATED NNodes "use [NNode text] instead" #-}+type NNodes text = [Node (NName text) text]  -- | Type shortcut for a single node where namespaced names are used for tags type NNode text = Node (NName text) text

@@ -0,0 +1,76 @@+-- | This module ported from Text.XML.Light.Proc+module Text.XML.Expat.Proc where++import Text.XML.Expat.Tree++import Data.Maybe(listToMaybe)++-- | Select only the elements from a list of XML content.+onlyElems          :: [Node tag text] -> [Node tag text]+onlyElems xs        = [ x | x@(Element _ _ _) <- xs ]++-- | Select only the text from a list of XML content.+onlyText           :: [Node tag text] -> [text]+onlyText xs         = [ x | Text x <- xs ]++-- | Find all immediate children with the given name.+findChildren       :: (GenericXMLString tag) => tag -> Node tag text -> [Node tag text]+findChildren q e    = filterChildren ((q ==) . eName) e++-- | Filter all immediate children wrt a given predicate.+filterChildren       :: (Node tag text -> Bool) -> Node tag text -> [Node tag text]+filterChildren _ (Text _) = []+filterChildren p e    = filter p (onlyElems (eChildren e))++-- | Filter all immediate children wrt a given predicate over their names.+filterChildrenName      :: (tag -> Bool) -> Node tag text -> [Node tag text]+filterChildrenName _ (Text _) = []+filterChildrenName p e   = filter (p . eName) (onlyElems (eChildren e))++-- | Find an immediate child with the given name.+findChild          :: (GenericXMLString tag) => tag -> Node tag text -> Maybe (Node tag text)+findChild q e       = listToMaybe (findChildren q e)++-- | Find an immediate child with the given name.+filterChild          :: (Node tag text -> Bool) -> Node tag text -> Maybe (Node tag text)+filterChild p e       = listToMaybe (filterChildren p e)++-- | Find an immediate child with name matching a predicate.+filterChildName      :: (tag -> Bool) -> Node tag text -> Maybe (Node tag text)+filterChildName p e   = listToMaybe (filterChildrenName p e)++-- | Find the left-most occurrence of an element matching given name.+findElement        :: (GenericXMLString tag) => tag -> Node tag text -> Maybe (Node tag text)+findElement q e     = listToMaybe (findElements q e)++-- | Filter the left-most occurrence of an element wrt. given predicate.+filterElement        :: (Node tag text -> Bool) -> Node tag text -> Maybe (Node tag text)+filterElement p e     = listToMaybe (filterElements p e)++-- | Filter the left-most occurrence of an element wrt. given predicate.+filterElementName     :: (tag -> Bool) -> Node tag text -> Maybe (Node tag text)+filterElementName p e  = listToMaybe (filterElementsName p e)++-- | Find all non-nested occurances of an element.+-- (i.e., once we have found an element, we do not search+-- for more occurances among the element's children).+findElements       :: (GenericXMLString tag) => tag -> Node tag text -> [Node tag text]+findElements qn e = filterElementsName (qn==) e++-- | Find all non-nested occurrences of an element wrt. given predicate.+-- (i.e., once we have found an element, we do not search+-- for more occurances among the element's children).+filterElements       :: (Node tag text -> Bool) -> Node tag text -> [Node tag text]+filterElements p e+ | p e        = [e]+ | otherwise  = case e of+                  Element n a c -> concatMap (filterElements p) $ onlyElems c+                  _             -> []++-- | Find all non-nested occurences of an element wrt a predicate over element names.+-- (i.e., once we have found an element, we do not search+-- for more occurances among the element's children).+filterElementsName       :: (tag -> Bool) -> Node tag text -> [Node tag text]+filterElementsName _ (Text _) = []+filterElementsName p e = filterElements (p.eName) e+

@@ -53,8 +53,11 @@ instance NFData text => NFData (QName text) where     rnf (QName pre loc) = rnf (pre, loc) --- | Type shortcut for nodes where qualified names are used for tags-type QNodes text = Nodes (QName text) text+-- | DEPRECATED: Use [QNode text] instead.+--+-- Type shortcut for nodes where qualified names are used for tags+{-# DEPRECATED QNodes "use [QNode text] instead" #-}+type QNodes text = [Node (QName text) text]  -- | Type shortcut for a single node where qualified names are used for tags type QNode text = Node (QName text) text

@@ -0,0 +1,409 @@+{-# LANGUAGE DeriveDataTypeable, TypeSynonymInstances #-}++-- hexpat, a Haskell wrapper for expat+-- Copyright (C) 2008 Evan Martin <martine@danga.com>+-- Copyright (C) 2009 Stephen Blackheath <http://blacksapphire.com/antispam>++-- | This module provides functions to parse an XML document to a lazy+-- stream of SAX events.+--++module Text.XML.Expat.SAX (+  -- * XML primitives+  Encoding(..),+  XMLParseError(..),+  XMLParseLocation(..),++  -- * SAX-style parse+  ParserOptions(..),+  SAXEvent(..),++  mkText,+  parse,+  parseLocations,+  parseLocationsThrowing,+  parseThrowing,+  defaultParserOptions,++  -- * Variants that throw exceptions+  XMLParseException(..),++  -- * Deprecated parse functions+  parseSAX,+  parseSAXLocations,+  parseSAXLocationsThrowing,+  parseSAXThrowing,++  -- * Abstraction of string types+  GenericXMLString(..)+) where++import Text.XML.Expat.IO hiding (parse)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Internal as I+import Data.IORef+import Data.ByteString.Internal (c2w, w2c, c_strlen)+import qualified Data.Monoid as M+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import qualified Codec.Binary.UTF8.String as U8+import Data.Monoid+import Data.Typeable+import Control.Exception.Extensible as Exc+import Control.Applicative+import Control.Parallel.Strategies+import Control.Monad+import System.IO.Unsafe+import Foreign.C.String+import Foreign.Ptr+++data ParserOptions tag text = ParserOptions+    { parserEncoding :: Maybe Encoding+          -- ^ The encoding parameter, if provided, overrides the document's+          -- encoding declaration.+    , entityDecoder  :: Maybe (tag -> Maybe text)+          -- ^ If provided, entity references (i.e. @&nbsp;@ and friends) will+          -- be decoded into text using the supplied lookup function+    }++defaultParserOptions :: ParserOptions tag text+defaultParserOptions = ParserOptions Nothing Nothing+++-- | An abstraction for any string type you want to use as xml text (that is,+-- attribute values or element text content). If you want to use a+-- new string type with /hexpat/, you must make it an instance of+-- 'GenericXMLString'.+class (M.Monoid s, Eq s) => GenericXMLString s where+    gxNullString :: s -> Bool+    gxToString :: s -> String+    gxFromString :: String -> s+    gxFromChar :: Char -> s+    gxHead :: s -> Char+    gxTail :: s -> s+    gxBreakOn :: Char -> s -> (s, s)+    gxFromCStringLen :: CStringLen -> IO s+    gxToByteString :: s -> B.ByteString++instance GenericXMLString String where+    gxNullString = null+    gxToString = id+    gxFromString = id+    gxFromChar c = [c]+    gxHead = head+    gxTail = tail+    gxBreakOn c = break (==c)+    gxFromCStringLen cstr = U8.decodeString <$> peekCStringLen cstr+    gxToByteString = B.pack . map c2w . U8.encodeString++instance GenericXMLString B.ByteString where+    gxNullString = B.null+    gxToString = U8.decodeString . map w2c . B.unpack+    gxFromString = B.pack . map c2w . U8.encodeString+    gxFromChar = B.singleton . c2w+    gxHead = w2c . B.head+    gxTail = B.tail+    gxBreakOn c = B.break (== c2w c)+    gxFromCStringLen = peekByteStringLen+    gxToByteString = id++instance GenericXMLString T.Text where+    gxNullString = T.null+    gxToString = T.unpack+    gxFromString = T.pack+    gxFromChar = T.singleton+    gxHead = T.head+    gxTail = T.tail+    gxBreakOn c = T.breakBy (==c)+    gxFromCStringLen cstr = TE.decodeUtf8 <$> peekByteStringLen cstr+    gxToByteString = TE.encodeUtf8++peekByteStringLen :: CStringLen -> IO B.ByteString+{-# INLINE peekByteStringLen #-}+peekByteStringLen (cstr, len) =+    I.create (fromIntegral len) $ \ptr ->+        I.memcpy ptr (castPtr cstr) (fromIntegral len)+++data SAXEvent tag text =+    StartElement tag [(tag, text)] |+    EndElement tag |+    CharacterData text |+    FailDocument XMLParseError+    deriving (Eq, Show)++instance (NFData tag, NFData text) => NFData (SAXEvent tag text) where+    rnf (StartElement tag atts) = rnf (tag, atts)+    rnf (EndElement tag) = rnf tag+    rnf (CharacterData text) = rnf text+    rnf (FailDocument err) = rnf err+++-- | Converts a 'CString' to a 'GenericXMLString' type.+mkText :: GenericXMLString text => CString -> IO text+{-# INLINE mkText #-}+mkText cstr = do+    len <- c_strlen cstr+    gxFromCStringLen (cstr, fromIntegral len)+++setEntityDecoder :: (GenericXMLString tag, GenericXMLString text)+                 => Parser+                 -> IORef [SAXEvent tag text]+                 -> (tag -> Maybe text)+                 -> IO ()+setEntityDecoder parser queueRef decoder = do+    setUseForeignDTD parser True+    setExternalEntityRefHandler parser eh+    setSkippedEntityHandler parser skip++  where+    skip _ 1 = return False+    skip entityName 0 = do+        en <- mkText entityName+        let mbt = decoder en+        maybe (return False)+              (\t -> do+                   modifyIORef queueRef (CharacterData t:)+                   return True)+              mbt+    skip _ _ = undefined++    eh p ctx _ systemID publicID =+        if systemID == nullPtr && publicID == nullPtr+           then withCStringLen "" $ \c -> do+               parseExternalEntityReference p ctx Nothing c+           else return False+++setEntityDecoderLoc :: (GenericXMLString tag, GenericXMLString text)+                    => Parser+                    -> IORef [(SAXEvent tag text, XMLParseLocation)]+                    -> (tag -> Maybe text)+                    -> IO ()+setEntityDecoderLoc parser queueRef decoder = do+    setUseForeignDTD parser True+    setExternalEntityRefHandler parser eh+    setSkippedEntityHandler parser skip++  where+    skip _ 1 = return False+    skip entityName 0 = do+        en <- mkText entityName+        let mbt = decoder en+        maybe (return False)+              (\t -> do+                   loc <- getParseLocation parser+                   modifyIORef queueRef ((CharacterData t,loc):)+                   return True)+              mbt+    skip _ _ = undefined++    eh p ctx _ systemID publicID =+        if systemID == nullPtr && publicID == nullPtr+           then withCStringLen "" $ \c -> do+               parseExternalEntityReference p ctx Nothing c+           else return False+++-- | 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) =>+         ParserOptions tag text -- ^ Parser options+      -> L.ByteString           -- ^ Input text (a lazy ByteString)+      -> [SAXEvent tag text]+parse opts input = unsafePerformIO $ do+    let enc = parserEncoding opts+    let mEntityDecoder = entityDecoder opts++    parser <- newParser enc+    queueRef <- newIORef []++    maybe (return ())+          (setEntityDecoder parser queueRef)+          mEntityDecoder++    setStartElementHandler parser $ \cName cAttrs -> do+        name <- mkText cName+        attrs <- forM cAttrs $ \(cAttrName,cAttrValue) -> do+            attrName <- mkText cAttrName+            attrValue <- mkText cAttrValue+            return (attrName, attrValue)+        modifyIORef queueRef (StartElement name attrs:)+        return True++    setEndElementHandler parser $ \cName -> do+        name <- mkText cName+        modifyIORef queueRef (EndElement name:)+        return True++    setCharacterDataHandler parser $ \cText -> do+        txt <- gxFromCStringLen cText+        modifyIORef queueRef (CharacterData txt:)+        return True++    let runParser inp = unsafeInterleaveIO $ do+            rema <- case inp of+                (c:cs) -> do+                    mError <- parseChunk parser c False+                    case mError of+                        Just err -> return [FailDocument err]+                        Nothing -> runParser cs+                [] -> do+                    mError <- parseChunk parser B.empty True+                    case mError of+                        Just err -> return [FailDocument err]+                        Nothing -> return []+            queue <- readIORef queueRef+            writeIORef queueRef []+            return $ reverse queue ++ rema++    runParser $ L.toChunks input+++-- | DEPRECATED: Use 'parse' instead.+--+-- Lazily parse XML to SAX events. In the event of an error, FailDocument is+-- the last element of the output list. Deprecated in favour of new+-- 'Text.XML.Expat.SAX.parse'+parseSAX :: (GenericXMLString tag, GenericXMLString text) =>+            Maybe Encoding      -- ^ Optional encoding override+         -> L.ByteString        -- ^ Input text (a lazy ByteString)+         -> [SAXEvent tag text]+{-# DEPRECATED parseSAX "use Text.XML.Expat.SAX.parse instead" #-}+parseSAX enc = parse (ParserOptions enc Nothing)+++-- | An exception indicating an XML parse error, used by the /..Throwing/ variants.+data XMLParseException = XMLParseException XMLParseError+    deriving (Eq, Show, Typeable)++instance Exception XMLParseException where+++-- | A variant of parseSAX that gives a document location with each SAX event.+parseLocations :: (GenericXMLString tag, GenericXMLString text) =>+                  ParserOptions tag text  -- ^ Parser options+               -> L.ByteString            -- ^ Input text (a lazy ByteString)+               -> [(SAXEvent tag text, XMLParseLocation)]+parseLocations opts input = unsafePerformIO $ do+    let enc = parserEncoding opts+    let mEntityDecoder = entityDecoder opts++    -- Done with cut & paste coding for maximum speed.+    parser <- newParser enc+    queueRef <- newIORef []++    maybe (return ())+          (setEntityDecoderLoc parser queueRef)+          mEntityDecoder++    setStartElementHandler parser $ \cName cAttrs -> do+        name <- mkText cName+        attrs <- forM cAttrs $ \(cAttrName,cAttrValue) -> do+            attrName <- mkText cAttrName+            attrValue <- mkText cAttrValue+            return (attrName, attrValue)+        loc <- getParseLocation parser+        modifyIORef queueRef ((StartElement name attrs,loc):)+        return True++    setEndElementHandler parser $ \cName -> do+        name <- mkText cName+        loc <- getParseLocation parser+        modifyIORef queueRef ((EndElement name, loc):)+        return True++    setCharacterDataHandler parser $ \cText -> do+        txt <- gxFromCStringLen cText+        loc <- getParseLocation parser+        modifyIORef queueRef ((CharacterData txt, loc):)+        return True++    let runParser [] = return []+        runParser (c:cs) = unsafeInterleaveIO $ do+            mError <- parseChunk parser c (null cs)+            queue <- readIORef queueRef+            writeIORef queueRef []+            rema <- case mError of+                Just err -> do+                    loc <- getParseLocation parser+                    return [(FailDocument err, loc)]+                Nothing -> runParser cs+            return $ reverse queue ++ rema++    runParser $ L.toChunks input+++-- | DEPRECATED: Use 'parseLocations' instead.+--+-- A variant of parseSAX that gives a document location with each SAX event.+parseSAXLocations :: (GenericXMLString tag, GenericXMLString text) =>+            Maybe Encoding      -- ^ Optional encoding override+         -> L.ByteString        -- ^ Input text (a lazy ByteString)+         -> [(SAXEvent tag text, XMLParseLocation)]+{-# DEPRECATED parseSAXLocations "use Text.XML.Expat.SAX.parseLocations instead" #-}+parseSAXLocations enc = parseLocations (ParserOptions enc Nothing)+++-- | Lazily parse XML to SAX events. 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) =>+                 ParserOptions tag text  -- ^ Parser options+              -> L.ByteString            -- ^ input text (a lazy ByteString)+              -> [SAXEvent tag text]+parseThrowing opts bs = map freakOut $ parse opts bs+  where+    freakOut (FailDocument err) = Exc.throw $ XMLParseException err+    freakOut other = other+++-- | DEPRECATED: Use 'parseThrowing' instead.+--+-- Lazily parse XML to SAX events. In the event of an error, throw+-- 'XMLParseException'.+parseSAXThrowing :: (GenericXMLString tag, GenericXMLString text) =>+                    Maybe Encoding      -- ^ Optional encoding override+                 -> L.ByteString        -- ^ Input text (a lazy ByteString)+                 -> [SAXEvent tag text]+{-# DEPRECATED parseSAXThrowing "use Text.XML.Expat.SAX.parseThrowing instead" #-}+parseSAXThrowing mEnc = parseThrowing (ParserOptions mEnc Nothing)+++-- | A variant of parseSAX that gives a document location with each SAX event.+-- In the event of an error, throw 'XMLParseException'.+--+-- @parseLocationsThrowing@ 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.+parseLocationsThrowing :: (GenericXMLString tag, GenericXMLString text) =>+                          ParserOptions tag text  -- ^ Optional encoding override+                       -> L.ByteString            -- ^ Input text (a lazy ByteString)+                       -> [(SAXEvent tag text, XMLParseLocation)]+parseLocationsThrowing opts bs = map freakOut $ parseLocations opts bs+  where+    freakOut (FailDocument err, _) = Exc.throw $ XMLParseException err+    freakOut other = other+++-- | DEPRECATED: Used 'parseLocationsThrowing' instead.+--+-- A variant of parseSAX that gives a document location with each SAX event.+-- In the event of an error, throw 'XMLParseException'.+parseSAXLocationsThrowing :: (GenericXMLString tag, GenericXMLString text) =>+                             Maybe Encoding      -- ^ Optional encoding override+                          -> L.ByteString        -- ^ Input text (a lazy ByteString)+                          -> [(SAXEvent tag text, XMLParseLocation)]+{-# DEPRECATED parseSAXLocationsThrowing "use Text.XML.Expat.SAX.parseLocationsThrowing instead" #-}+parseSAXLocationsThrowing mEnc =+    parseLocationsThrowing (ParserOptions mEnc Nothing)

@@ -7,8 +7,8 @@ -- | This module provides functions to parse an XML document to a tree structure, -- either strictly or lazily, as well as a lazy SAX-style interface. ----- The GenericXMLString type class allows you to use any string type. Three--- string types are provided for here: @String@, @ByteString@ and @Text@.+-- The 'GenericXMLString' type class allows you to use any string type. Three+-- string types are provided for here: 'String', 'ByteString' and 'Text'. -- -- Here is a complete example to get you started: --@@ -35,9 +35,9 @@ -- >     inputText <- L.readFile filename -- >     -- Note: Because we're not using the tree, Haskell can't infer the type of -- >     -- strings we're using so we need to tell it explicitly with a type signature.--- >     let (xml, mErr) = parseTree Nothing inputText :: (UNode String, Maybe XMLParseError)+-- >     let (xml, mErr) = parse defaultParserOptions inputText :: (UNode String, Maybe XMLParseError) -- >     -- Process document before handling error, so we get lazy processing.--- >     L.hPutStr stdout $ formatTree xml+-- >     L.hPutStr stdout $ format xml -- >     putStrLn "" -- >     case mErr of -- >         Nothing -> return ()@@ -57,16 +57,23 @@ -- > -- > -- This is the recommended way to handle errors in lazy parses -- > main = do--- >     let (tree, mError) = parseTree Nothing (L.pack $ map c2w $ "<top><banana></apple></top>")+-- >     let (tree, mError) = parse defaultParserOptions+-- >                    (L.pack $ map c2w $ "<top><banana></apple></top>") -- >     print (tree :: UNode String)--- >     -- Note: We check the error _after_ we have finished our processing on the tree.+-- >+-- >     -- Note: We check the error _after_ we have finished our processing+-- >     -- on the tree. -- >     case mError of -- >         Just err -> putStrLn $ "It failed : "++show err -- >         Nothing -> putStrLn "Success!" -- -- Way no. 2 - Using exceptions ----- Unless exceptions fit in with the design of your program, this way is less preferred.+-- '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. -- -- > ... -- > import Control.Exception.Extensible as E@@ -74,10 +81,11 @@ -- > -- This is not the recommended way to handle errors. -- > main = do -- >     do--- >         let tree = parseTreeThrowing Nothing (L.pack $ map c2w $ "<top><banana></apple></top>")+-- >         let tree = parseThrowing defaultParserOptions+-- >                        (L.pack $ map c2w $ "<top><banana></apple></top>") -- >         print (tree :: UNode String)--- >         -- Because of lazy evaluation, you should not process the tree outside the 'do' block,--- >         -- or exceptions could be thrown that won't get caught.+-- >         -- Because of lazy evaluation, you should not process the tree outside+-- >         -- the 'do' block, or exceptions could be thrown that won't get caught. -- >     `E.catch` (\exc -> -- >         case E.fromException exc of -- >             Just (XMLParseException err) -> putStrLn $ "It failed : "++show err@@ -92,107 +100,82 @@   UNodes,   UAttributes,   textContent,-  extractText,-  -- * Parse to tree+  isElement,+  isNamed,+  isText,+  getAttribute,+  getChildren,+  modifyChildren,++  -- * Parse functions+  ParserOptions(..),+  defaultParserOptions,+  parse,+  parse',+  parseThrowing,++  -- * Deprecated parse functions   parseTree,   parseTree',++  parseSAX,+  parseSAXLocations,++  parseTreeThrowing,+  parseSAXThrowing,+  parseSAXLocationsThrowing,++  extractText,++  -- * Parse to tree   Encoding(..),   XMLParseError(..),   XMLParseLocation(..),+   -- * SAX-style parse-  parseSAX,   SAXEvent(..),   saxToTree,-  parseSAXLocations,+   -- * Variants that throw exceptions   XMLParseException(..),-  parseTreeThrowing,-  parseSAXThrowing,-  parseSAXLocationsThrowing,+   -- * Abstraction of string types   GenericXMLString(..) ) where -import Text.XML.Expat.IO-import qualified Data.ByteString as B+------------------------------------------------------------------------------+import Text.XML.Expat.IO hiding (parse,parse')+import qualified Text.XML.Expat.IO as IO++import Text.XML.Expat.SAX ( Encoding(..)+                          , ParserOptions(..)+                          , XMLParseException(..)+                          , XMLParseError(..)+                          , XMLParseLocation(..)+                          , SAXEvent(..)+                          , defaultParserOptions+                          , mkText+                          , parseSAX+                          , parseSAXLocations+                          , parseSAXLocationsThrowing+                          , parseSAXThrowing+                          , GenericXMLString(..) )+import qualified Text.XML.Expat.SAX as SAX++------------------------------------------------------------------------------+import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Internal as I import Data.IORef-import System.IO.Unsafe (unsafePerformIO)-import Data.ByteString.Internal (c2w, w2c, c_strlen) import qualified Data.Monoid as M-import qualified Data.Text as T-import qualified Data.Text.Encoding as TE-import qualified Codec.Binary.UTF8.String as U8 import Data.Monoid-import Data.Typeable-import Control.Exception.Extensible as Exc-import Control.Applicative-import Control.Concurrent-import Control.Concurrent.MVar import Control.Parallel.Strategies import Control.Monad import System.IO.Unsafe-import System.Mem.Weak import Foreign.C.String import Foreign.Ptr  --- | An abstraction for any string type you want to use as xml text (that is,--- attribute values or element text content). If you want to use a--- new string type with /hexpat/, you must make it an instance of--- 'GenericXMLString'.-class (M.Monoid s, Eq s) => GenericXMLString s where-    gxNullString :: s -> Bool-    gxToString :: s -> String-    gxFromString :: String -> s-    gxFromChar :: Char -> s-    gxHead :: s -> Char-    gxTail :: s -> s-    gxBreakOn :: Char -> s -> (s, s)-    gxFromCStringLen :: CStringLen -> IO s-    gxToByteString :: s -> B.ByteString--instance GenericXMLString String where-    gxNullString = null-    gxToString = id-    gxFromString = id-    gxFromChar c = [c]-    gxHead = head-    gxTail = tail-    gxBreakOn c = break (==c)-    gxFromCStringLen cstr = U8.decodeString <$> peekCStringLen cstr-    gxToByteString = B.pack . map c2w . U8.encodeString--instance GenericXMLString B.ByteString where-    gxNullString = B.null-    gxToString = U8.decodeString . map w2c . B.unpack-    gxFromString = B.pack . map c2w . U8.encodeString-    gxFromChar = B.singleton . c2w-    gxHead = w2c . B.head-    gxTail = B.tail-    gxBreakOn c = B.break (== c2w c)-    gxFromCStringLen = peekByteStringLen-    gxToByteString = id--instance GenericXMLString T.Text where-    gxNullString = T.null-    gxToString = T.unpack-    gxFromString = T.pack-    gxFromChar = T.singleton-    gxHead = T.head-    gxTail = T.tail-    gxBreakOn c = T.breakBy (==c)-    gxFromCStringLen cstr = TE.decodeUtf8 <$> peekByteStringLen cstr-    gxToByteString = TE.encodeUtf8--peekByteStringLen :: CStringLen -> IO B.ByteString-{-# INLINE peekByteStringLen #-}-peekByteStringLen (cstr, len) =-    I.create (fromIntegral len) $ \ptr ->-        I.memcpy ptr (castPtr cstr) (fromIntegral len)-- -- | The tree representation of the XML document. data Node tag text =     Element {@@ -210,12 +193,18 @@ -- | Type shortcut for attributes type Attributes tag text = [(tag, text)] --- | Type shortcut for nodes+-- | DEPRECATED: Use [Node tag text] instead.+--+-- Type shortcut for nodes. type Nodes tag text = [Node tag text]+{-# DEPRECATED Nodes "use [Node tag text] instead" #-} --- | Type shortcut for nodes with unqualified tag names where tag and--- text are the same string type.+-- | DEPRECATED: Use [UNode text] instead.+--+-- Type shortcut for nodes with unqualified tag names where tag and+-- text are the same string type. Deprecated type UNodes text = Nodes text text+{-# DEPRECATED UNodes "use [UNode text] instead" #-}  -- | Type shortcut for a single node with unqualified tag names where tag and -- text are the same string type.@@ -231,34 +220,96 @@ textContent (Element _ _ children) = mconcat $ map textContent children textContent (Text txt) = txt --- | Deprecated - renamed to textContent.+-- | DEPRECATED: Renamed to 'textContent'. extractText :: Monoid text => Node tag text -> text {-# DEPRECATED extractText "renamed to textContent" #-} extractText = textContent +-- | Is the given node an element?+isElement :: Node tag text -> Bool+isElement (Element _ _ _) = True+isElement _               = False++-- | Is the given node text?+isText :: Node tag text -> Bool+isText (Text _) = True+isText _        = False++-- | Is the given node a tag with the given name?+isNamed :: (Eq tag) => tag -> Node tag text -> Bool+isNamed _  (Text _) = False+isNamed nm (Element nm' _ _) = nm == nm'++-- | Get the value of the attribute having the specified name.+getAttribute :: GenericXMLString tag => Node tag text -> tag -> Maybe text+getAttribute n t = lookup t $ eAttrs n++-- | Get children of a node if it's an element, return empty list otherwise.+getChildren :: Node tag text -> [Node tag text]+getChildren (Text _)         = []+getChildren (Element _ _ ch) = ch++-- | Modify a node's children using the specified function. modifyChildren :: ([Node tag text] -> [Node tag text])                -> Node tag text                -> Node tag text-modifyChildren f node = node { eChildren = f (eChildren node) }+modifyChildren _ node@(Text _) = node+modifyChildren f (Element n a c) = Element n a (f c) -mkText :: GenericXMLString text => CString -> IO text-{-# INLINE mkText #-}-mkText cstr = do-    len <- c_strlen cstr-    gxFromCStringLen (cstr, fromIntegral len) +setEntityDecoder :: (GenericXMLString tag, GenericXMLString text)+                 => Parser+                 -> IORef [Node tag text]+                 -> (tag -> Maybe text)+                 -> IO ()+setEntityDecoder parser queueRef decoder = do+    setUseForeignDTD parser True+    setExternalEntityRefHandler parser eh+    setSkippedEntityHandler parser skip++  where+    text str (cur:rest) = modifyChildren (Text str:) cur : rest+    text _ [] = undefined++    skip _ 1 = return False+    skip entityName 0 = do+        en <- mkText entityName+        let mbt = decoder en+        maybe (return False)+              (\t -> do+                   modifyIORef queueRef $ text t+                   return True)+              mbt+    skip _ _ = undefined++    eh p ctx _ systemID publicID =+        if systemID == nullPtr && publicID == nullPtr+           then withCStringLen "" $ \c -> do+               parseExternalEntityReference p ctx Nothing c+           else return False++ -- | Strictly parse XML to tree. Returns error message or valid parsed tree.-parseTree' :: (GenericXMLString tag, GenericXMLString text) =>-              Maybe Encoding      -- ^ Optional encoding override-           -> B.ByteString        -- ^ Input text (a strict ByteString)-           -> Either XMLParseError (Node tag text)-parseTree' enc doc = unsafePerformIO $ runParse where+parse' :: (GenericXMLString tag, GenericXMLString text) =>+          ParserOptions tag text  -- ^ Parser options+       -> ByteString              -- ^ Input text (a strict ByteString)+       -> Either XMLParseError (Node tag text)+parse' opts doc = unsafePerformIO $ runParse where   runParse = do+    let enc = parserEncoding opts+    let mEntityDecoder = entityDecoder opts+     parser <- newParser enc+     -- We maintain the invariant that the stack always has one element,     -- whose only child at the end of parsing is the root of the actual tree.     let emptyString = gxFromString ""     stack <- newIORef [Element emptyString [] []]++    maybe (return ())+          (setEntityDecoder parser stack)+          mEntityDecoder+     setStartElementHandler parser $ \cName cAttrs -> do         name <- mkText cName         attrs <- forM cAttrs $ \(cAttrName,cAttrValue) -> do@@ -267,16 +318,16 @@             return (attrName, attrValue)         modifyIORef stack (start name attrs)         return True-    setEndElementHandler parser $ \cName -> do+    setEndElementHandler parser $ \_ -> do         modifyIORef stack end         return True     setCharacterDataHandler parser $ \cText -> do         txt <- gxFromCStringLen cText         modifyIORef stack (text txt)         return True-    mError <- parse' parser doc+    mError <- IO.parse' parser doc     case mError of-        Just error -> return $ Left error+        Just err -> return $ Left err         Nothing -> do             [Element _ _ [root]] <- readIORef stack             return $ Right root@@ -288,135 +339,20 @@     let node = modifyChildren reverse cur in     modifyChildren (node:) parent : rest   end _ = impossible-  impossible = error "parseTree' impossible"+  impossible = error "parse' impossible" -data SAXEvent tag text =-    StartElement tag [(tag, text)] |-    EndElement tag |-    CharacterData text |-    FailDocument XMLParseError-    deriving (Eq, Show) -instance (NFData tag, NFData text) => NFData (SAXEvent tag text) where-    rnf (StartElement tag atts) = rnf (tag, atts)-    rnf (EndElement tag) = rnf tag-    rnf (CharacterData text) = rnf text-    rnf (FailDocument err) = rnf err+-- | DEPRECATED: use 'parse' instead.+--+-- Strictly parse XML to tree. Returns error message or valid parsed tree.+parseTree' :: (GenericXMLString tag, GenericXMLString text) =>+              Maybe Encoding      -- ^ Optional encoding override+           -> ByteString          -- ^ Input text (a strict ByteString)+           -> Either XMLParseError (Node tag text)+{-# DEPRECATED parseTree' "use Text.XML.Expat.parse' instead" #-}+parseTree' enc = parse' (ParserOptions enc Nothing) --- | Lazily parse XML to SAX events. In the event of an error, FailDocument is--- the last element of the output list.-parseSAX :: (GenericXMLString tag, GenericXMLString text) =>-            Maybe Encoding      -- ^ Optional encoding override-         -> L.ByteString        -- ^ Input text (a lazy ByteString)-         -> [SAXEvent tag text]-parseSAX enc input = unsafePerformIO $ do-    parser <- newParser enc-    queueRef <- newIORef []-    setStartElementHandler parser $ \cName cAttrs -> do-        name <- mkText cName-        attrs <- forM cAttrs $ \(cAttrName,cAttrValue) -> do-            attrName <- mkText cAttrName-            attrValue <- mkText cAttrValue-            return (attrName, attrValue)-        modifyIORef queueRef (StartElement name attrs:)-        return True-    setEndElementHandler parser $ \cName -> do-        name <- mkText cName-        modifyIORef queueRef (EndElement name:)-        return True-    setCharacterDataHandler parser $ \cText -> do-        txt <- gxFromCStringLen cText-        modifyIORef queueRef (CharacterData txt:)-        return True -    let runParser input = unsafeInterleaveIO $ do-            rem <- case input of-                (c:cs) -> do-                    mError <- parseChunk parser c False-                    case mError of-                        Just error -> return [FailDocument error]-                        Nothing -> runParser cs-                [] -> do-                    mError <- parseChunk parser B.empty True-                    case mError of-                        Just error -> return [FailDocument error]-                        Nothing -> return []-            queue <- readIORef queueRef-            writeIORef queueRef []-            return $ reverse queue ++ rem--    runParser $ L.toChunks input---- | An exception indicating an XML parse error, used by the /..Throwing/ variants.-data XMLParseException = XMLParseException XMLParseError-    deriving (Eq, Show, Typeable)--instance Exception XMLParseException where---- | A variant of parseSAX that gives a document location with each SAX event.-parseSAXLocations :: (GenericXMLString tag, GenericXMLString text) =>-            Maybe Encoding      -- ^ Optional encoding override-         -> L.ByteString        -- ^ Input text (a lazy ByteString)-         -> [(SAXEvent tag text, XMLParseLocation)]-parseSAXLocations enc input = unsafePerformIO $ do-    -- Done with cut & paste coding for maximum speed.-    parser <- newParser enc-    queueRef <- newIORef []-    setStartElementHandler parser $ \cName cAttrs -> do-        name <- mkText cName-        attrs <- forM cAttrs $ \(cAttrName,cAttrValue) -> do-            attrName <- mkText cAttrName-            attrValue <- mkText cAttrValue-            return (attrName, attrValue)-        loc <- getParseLocation parser-        modifyIORef queueRef ((StartElement name attrs,loc):)-        return True-    setEndElementHandler parser $ \cName -> do-        name <- mkText cName-        loc <- getParseLocation parser-        modifyIORef queueRef ((EndElement name, loc):)-        return True-    setCharacterDataHandler parser $ \cText -> do-        txt <- gxFromCStringLen cText-        loc <- getParseLocation parser-        modifyIORef queueRef ((CharacterData txt, loc):)-        return True--    let runParser [] = return []-        runParser (c:cs) = unsafeInterleaveIO $ do-            mError <- parseChunk parser c (null cs)-            queue <- readIORef queueRef-            writeIORef queueRef []-            rem <- case mError of-                Just error -> do-                    loc <- getParseLocation parser-                    return [(FailDocument error, loc)]-                Nothing -> runParser cs-            return $ reverse queue ++ rem--    runParser $ L.toChunks input---- | Lazily parse XML to SAX events. In the event of an error, throw 'XMLParseException'.-parseSAXThrowing :: (GenericXMLString tag, GenericXMLString text) =>-                    Maybe Encoding      -- ^ Optional encoding override-                 -> L.ByteString        -- ^ Input text (a lazy ByteString)-                 -> [SAXEvent tag text]-parseSAXThrowing mEnc bs = map freakOut $ parseSAX mEnc bs-  where-    freakOut (FailDocument err) = Exc.throw $ XMLParseException err-    freakOut other = other---- | A variant of parseSAX that gives a document location with each SAX event.--- In the event of an error, throw 'XMLParseException'.-parseSAXLocationsThrowing :: (GenericXMLString tag, GenericXMLString text) =>-                             Maybe Encoding      -- ^ Optional encoding override-                          -> L.ByteString        -- ^ Input text (a lazy ByteString)-                          -> [(SAXEvent tag text, XMLParseLocation)]-parseSAXLocationsThrowing mEnc bs = map freakOut $ parseSAXLocations mEnc bs-  where-    freakOut (FailDocument err, _) = Exc.throw $ XMLParseException err-    freakOut other = other- -- | A lower level function that lazily converts a SAX stream into a tree structure. saxToTree :: GenericXMLString tag =>              [SAXEvent tag text]@@ -427,30 +363,62 @@   where     safeHead (a:_) = a     safeHead [] = Element (gxFromString "") [] []-    ptl (StartElement name attrs:rem) =-        let (children, err1, rem') = ptl rem+    ptl (StartElement name attrs:rema) =+        let (children, err1, rema') = ptl rema             elt = Element name attrs children-            (out, err2, rem'') = ptl rem'-        in  (elt:out, err1 `mplus` err2, rem'')-    ptl (EndElement name:rem) = ([], Nothing, rem)-    ptl (CharacterData txt:rem) =-        let (out, err, rem') = ptl rem-        in  (Text txt:out, err, rem')+            (out, err2, rema'') = ptl rema'+        in  (elt:out, err1 `mplus` err2, rema'')+    ptl (EndElement _:rema) = ([], Nothing, rema)+    ptl (CharacterData txt:rema) =+        let (out, err, rema') = ptl rema+        in  (Text txt:out, err, rema')     ptl (FailDocument err:_) = ([], Just err, [])     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) =>+         ParserOptions tag text   -- ^ Parser options+      -> L.ByteString             -- ^ Input text (a lazy ByteString)+      -> (Node tag text, Maybe XMLParseError)+parse opts bs = saxToTree $ SAX.parse opts bs+++-- | DEPREACTED: Use 'parse' instead.+--+-- 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. parseTree :: (GenericXMLString tag, GenericXMLString text) =>              Maybe Encoding      -- ^ Optional encoding override           -> L.ByteString        -- ^ Input text (a lazy ByteString)           -> (Node tag text, Maybe XMLParseError)-parseTree mEnc bs = saxToTree $ parseSAX mEnc bs+{-# DEPRECATED parseTree "use Text.XML.Expat.Tree.parse instead" #-}+parseTree mEnc = parse (ParserOptions mEnc Nothing) + -- | 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) =>+         ParserOptions tag text -- ^ Parser options+      -> L.ByteString           -- ^ Input text (a lazy ByteString)+      -> Node tag text+parseThrowing opts bs = fst $ saxToTree $ SAX.parseThrowing opts bs+++-- | DEPRECATED: Use 'parseThrowing' instead.+--+-- Lazily parse XML to tree. In the event of an error, throw 'XMLParseException'. parseTreeThrowing :: (GenericXMLString tag, GenericXMLString text) =>              Maybe Encoding      -- ^ Optional encoding override           -> L.ByteString        -- ^ Input text (a lazy ByteString)           -> Node tag text-parseTreeThrowing mEnc bs = fst $ saxToTree $ parseSAXThrowing mEnc bs+{-# DEPRECATED parseTreeThrowing "use Text.XML.Expat.Tree.parseThrowing instead" #-}+parseTreeThrowing mEnc = parseThrowing (ParserOptions mEnc Nothing)

@@ -1,44 +1,45 @@ Cabal-Version: >= 1.4 Name: hexpat-Version: 0.10+Version: 0.11 Synopsis: wrapper for expat, the fast XML parser Description:-  Expat (<http://expat.sourceforge.net/>) is a stream-oriented XML parser-  written in C.+  This package provides a general purpose Haskell XML library using the Expat do+  do its parsing (<http://expat.sourceforge.net/> - a fast stream-oriented XML+  parser written in C).  It is extensible to any string type, with @String@,+  @ByteString@ and @Text@ provided out of the box.   .-  This package provides a Haskell binding for Expat, with a choice of /tree/ or-  /SAX-style/ representation, and it includes an /XML formatter/.  It is extensible-  to any string type, with @String@, @ByteString@ and @Text@ provided out of the box.+  Basic usage: Parsing a tree (/Tree/), formatting a tree (/Format/).   .-  The emphasis is on speed and simplicity. If you want more complete and powerful-  XML libraries, consider using /HaXml/ or /HXT/ instead.+  Other features: Helpers for processing XML trees (/Proc/), trees annotated with+  XML source location (/Annotated/), XML cursors (/Cursor/), more intelligent+  handling of qualified tag names (/Qualified/), tags qualified with namespaces+  (/Namespaced/), SAX-style parse (/SAX/), and access to the low-level interface+  in case speed is paramount (/IO/).   .+  The design goals are speed, speed, speed, interface simplicity and modular design.+  .   Examples and benchmarks: <http://haskell.org/haskellwiki/Hexpat/>   .   DARCS repository: <http://code.haskell.org/hexpat/>+  .+  Credits to the @xml@ (XML.Light) package for /Proc/ and /Cursor/. Category: XML License: BSD3 License-File: LICENSE-Author: Stephen Blackheath (blackh), Evan Martin, Matthew Pocock (drdozer)+Author:+  Doug Beardsley,+  Stephen Blackheath (blackh),+  Gregory Collins,+  Evan Martin,+  Matthew Pocock (drdozer) Maintainer: http://blacksapphire.com/antispam/ Copyright:+  (c) 2009 Doug Beardsley <mightybyte@gmail.com>,   (c) 2009 Stephen Blackheath <http://blacksapphire.com/antispam/>,+  (c) 2009 Gregory Collins,   (c) 2008 Evan Martin <martine@danga.com>,   (c) 2009 Matthew Pocock <matthew.pocock@ncl.ac.uk> Homepage: http://haskell.org/haskellwiki/Hexpat/-Extra-Source-Files:-  test/tests.hs,-  test/test.xml,-  test/benchmark.hs,-  test/lazySAX.hs,-  test/lazyTree.hs,-  test/lazyTreeThrow.hs,-  test/leak.hs,-  test/errorHandlingWay1.hs,-  test/errorHandlingWay2.hs,-  test/helloworld.hs,-  test/locations.hs,-  test/Makefile Build-Type: Simple Stability: beta @@ -55,10 +56,13 @@     extensible-exceptions >= 0.1 && < 0.2   Exposed-Modules:     Text.XML.Expat.Annotated,-    Text.XML.Expat.Tree,+    Text.XML.Expat.Cursor,     Text.XML.Expat.Format,+    Text.XML.Expat.IO,     Text.XML.Expat.Namespaced,+    Text.XML.Expat.Proc,     Text.XML.Expat.Qualified,-    Text.XML.Expat.IO+    Text.XML.Expat.SAX,+    Text.XML.Expat.Tree   Extra-Libraries: expat-+  --ghc-options: -Wall

@@ -1,28 +0,0 @@-all: tests lazySAX lazyTree lazyTreeThrow benchmark leak helloworld locations--tests: tests.hs-	ghc -O2 --make -o tests tests.hs--lazySAX: lazySAX.hs-	ghc -O2 --make -o lazySAX lazySAX.hs--lazyTree: lazyTree.hs-	ghc -O2 --make -o lazyTree lazyTree.hs--lazyTreeThrow: lazyTreeThrow.hs-	ghc -O2 --make -o lazyTreeThrow lazyTreeThrow.hs--benchmark: benchmark.hs-	ghc -O2 --make -o benchmark benchmark.hs #-threaded--leak: leak.hs-	ghc -O2 --make -o leak leak.hs -threaded--helloworld: helloworld.hs-	ghc -O2 --make -o helloworld helloworld.hs--locations: locations.hs-	ghc -O2 --make -o locations locations.hs--clean:-	rm -f tests perf lazySAX lazyTree benchmark leak helloworld locations *.hi *.o

@@ -1,84 +0,0 @@-import Text.XML.Expat.Tree-import Text.XML.Expat.Format-import Text.XML.Expat.Qualified-import Text.XML.Expat.IO-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as L-import Data.ByteString.Internal (c2w, w2c)-import qualified Data.ByteString.Internal as I-import qualified Data.Text as T-import Data.Char-import Data.Maybe-import Control.Exception as E-import Control.Monad-import Control.Parallel.Strategies-import Test.HUnit hiding (Node)-import System.IO-import Foreign.ForeignPtr-import Foreign.Ptr-import Microbench-import Text.XML.HaXml as HaXml--instance NFData B.ByteString where-    rnf bs = ()--instance NFData T.Text where-    rnf bs = ()--instance NFData Document where-    rnf (Document _ _ root _) = rnf root--instance NFData Element where-    rnf (Elem name attrs content) = rnf (name, attrs, content)--instance NFData AttValue where-    rnf (AttValue val) = rnf val--instance NFData Reference where-    rnf ref = ()--instance NFData Content where-    rnf content = ()--parseOnly :: B.ByteString -> String -> IO ()-parseOnly xml _ = do-    parser <- newParser Nothing-    parse' parser xml-    return ()--myParseTree enc xml = parseTree enc (L.fromChunks [xml])--fromRight :: Either XMLParseError a -> a-fromRight x = case x of-    Right right -> right-    Left err -> error (show err)--tests :: [(String, B.ByteString -> String -> IO ())]-tests = [-    ("HaXml", \_ xml -> rnf (HaXml.xmlParse "input" xml) `seq` return ()),-    ("low-level parse only, no tree", parseOnly),-    ("lazy parseTree string", \xml _ -> rnf (fst $ myParseTree Nothing xml :: UNode String) `seq` return ()),-    ("lazy parseTree byteString", \xml _ -> rnf (fst $ myParseTree Nothing xml :: UNode B.ByteString) `seq` return ()),-    ("lazy parseTree text", \xml _ -> rnf (fst $ myParseTree Nothing xml :: UNode T.Text) `seq` return ()),-    ("lazy parseTree qualifiedString", \xml _ -> rnf (toQualified $ fst $ myParseTree Nothing xml :: QNode String) `seq` return ()),-    ("lazy parseTree qualifiedByteString", \xml _ -> rnf (toQualified $ fst $ myParseTree Nothing xml :: QNode B.ByteString) `seq` return ()),-    ("lazy parseTree qualifiedText", \xml _ -> (toQualified $ fst $ myParseTree Nothing xml :: QNode T.Text) `seq` return ()),-    ("strict parseTree' string", \xml _ -> rnf (fromRight $ parseTree' Nothing xml :: UNode String) `seq` return ()),-    ("strict parseTree' byteString", \xml _ -> rnf (fromRight $ parseTree' Nothing xml :: UNode B.ByteString) `seq` return ()),-    ("strict parseTree' text", \xml _ -> rnf (fromRight $ parseTree' Nothing xml :: UNode T.Text) `seq` return ()),-    ("strict parseTree' qualifiedString", \xml _ -> rnf (toQualified $ fromRight $ parseTree' Nothing xml :: QNode String) `seq` return ()),-    ("strict parseTree' qualifiedByteString", \xml _ -> rnf (toQualified $ fromRight $ parseTree' Nothing xml :: QNode B.ByteString) `seq` return ()),-    ("strict parseTree' qualifiedText", \xml _ -> rnf (toQualified $ fromRight $ parseTree' Nothing xml :: QNode T.Text) `seq` return ())-  ]--myCopy :: B.ByteString -> IO B.ByteString-myCopy (I.PS x s l) = I.create l $ \p -> withForeignPtr x $ \f ->-    I.memcpy p (f `plusPtr` s) (fromIntegral l)--main = do-    xml <- B.readFile "test.xml"-    forM_ tests $ \(a,b) -> microbench a $ do-        copy <- myCopy xml-        let xmlStr = map w2c $ B.unpack copy-        b copy xmlStr-

@@ -1,12 +0,0 @@-import Text.XML.Expat.Tree-import qualified Data.ByteString.Lazy as L-import Data.ByteString.Internal (c2w)---- This is the recommended way to handle errors in lazy parses-main = do-    let (tree, mError) = parseTree Nothing (L.pack $ map c2w $ "<top><banana></apple></top>")-    print (tree :: UNode String)-    -- Note: We check the error _after_ we have finished our processing on the tree.-    case mError of-        Just err -> putStrLn $ "It failed : "++show err-        Nothing -> putStrLn "Success!"

@@ -1,16 +0,0 @@-import Text.XML.Expat.Tree-import qualified Data.ByteString.Lazy as L-import Data.ByteString.Internal (c2w)-import Control.Exception.Extensible as E---- This is not the recommended way to handle errors. See errorHandlingWay1.hs-main = do-    do-        let tree = parseTreeThrowing Nothing (L.pack $ map c2w $ "<top><banana></apple></top>")-        print (tree :: UNode String)-        -- Because of lazy evaluation, you should not process the tree outside the 'do' block,-        -- or exceptions could be thrown that won't get caught.-    `E.catch` (\exc ->-        case E.fromException exc of-            Just (XMLParseException err) -> putStrLn $ "It failed : "++show err-            Nothing -> E.throwIO exc)

@@ -1,33 +0,0 @@--- | A "hello world" example of hexpat that lazily parses a document, printing--- it to standard out.--import Text.XML.Expat.Tree-import Text.XML.Expat.Format-import System.Environment-import System.Exit-import System.IO-import qualified Data.ByteString.Lazy as L--main = do-    args <- getArgs-    case args of-        [filename] -> process filename-        otherwise  -> do-            hPutStrLn stderr "Usage: helloworld <file.xml>"-            exitWith $ ExitFailure 1--process :: String -> IO ()-process filename = do-    inputText <- L.readFile filename-    -- Note: Because we're not using the tree, Haskell can't infer the type of-    -- strings we're using so we need to tell it explicitly with a type signature.-    let (xml, mErr) = parseTree Nothing inputText :: (UNode String, Maybe XMLParseError)-    -- Process document before handling error, so we get lazy processing.-    L.hPutStr stdout $ formatTree xml-    putStrLn ""-    case mErr of-        Nothing -> return ()-        Just err -> do-            hPutStrLn stderr $ "XML parse failed: "++show err-            exitWith $ ExitFailure 2-

@@ -1,25 +0,0 @@-module Main where--import Text.XML.Expat.Tree-import qualified Data.ByteString as B-import Data.ByteString.Internal (c2w, w2c)-import qualified Data.ByteString.Lazy as L-import Control.Monad--infiniteDoc = "<?xml version=\"1.0\"?><infinite>"++body 1-    where-        body i = "\n  <item idx=\"" ++ show i ++ "\"/>"++body (i+1)--toBL :: String -> L.ByteString-toBL = L.fromChunks . chunkify-  where-    chunkify [] = []-    chunkify str =-        let (start, rem) = splitAt 1024 str-        in  (B.pack $ map c2w start):chunkify rem--infiniteBL = toBL infiniteDoc--main = do-    mapM_ print (parseSAX Nothing infiniteBL :: [SAXEvent B.ByteString B.ByteString])-

@@ -1,25 +0,0 @@-module Main where--import Text.XML.Expat.Tree-import qualified Data.ByteString as B-import Data.ByteString.Internal (c2w, w2c)-import qualified Data.ByteString.Lazy as L-import Control.Monad--infiniteDoc = "<?xml version=\"1.0\"?><infinite>"++body 1-    where-        body i = "\n  <item idx=\"" ++ show i ++ "\"/>"++body (i+1)--toBL :: String -> L.ByteString-toBL = L.fromChunks . chunkify-  where-    chunkify [] = []-    chunkify str =-        let (start, rem) = splitAt 1024 str-        in  (B.pack $ map c2w start):chunkify rem--infiniteBL = toBL infiniteDoc--main = do-    print (fst $ parseTree Nothing infiniteBL :: UNode B.ByteString)-

@@ -1,28 +0,0 @@-module Main where--import Text.XML.Expat.Tree-import qualified Data.ByteString as B-import Data.ByteString.Internal (c2w, w2c)-import qualified Data.ByteString.Lazy as L-import Control.Monad--infiniteDoc = "<?xml version=\"1.0\"?><infinite>"++body 1-    where-        body i | i == 5000 = "</bad-xml>" ++ body (i+1)-        body i = "\n  <item idx=\"" ++ show i ++ "\"/>"++body (i+1)--toBL :: String -> L.ByteString-toBL = L.fromChunks . chunkify-  where-    chunkify [] = []-    chunkify str =-        let (start, rem) = splitAt 1024 str-        in  (B.pack $ map c2w start):chunkify rem--infiniteBL = toBL infiniteDoc---- This test passes if it raises an exception when it gets bad XML.--main = do-    print $ (parseTreeThrowing Nothing infiniteBL :: UNode B.ByteString)-

@@ -1,63 +0,0 @@--- Memory leak test------ This test passes if you can leave it running for several minutes, and it--- does not leak memory or exhibit any other undesirable behaviour.--module Main where--import Text.XML.Expat.Tree-import qualified Data.ByteString as B-import Data.ByteString.Internal (c2w, w2c)-import qualified Data.ByteString.Lazy as L-import qualified Data.ByteString.Internal as I-import Control.Concurrent-import Control.Monad-import Control.Parallel.Strategies-import Foreign.ForeignPtr-import Foreign.Ptr--longDoc = "<?xml version=\"1.0\"?><long>"++body 1-    where-        body 10000 = "</long>"-        body i = "\n  <item idx=\"" ++ show i ++ "\"/>"++body (i+1)--toBL :: String -> L.ByteString-toBL = L.fromChunks . chunkify-  where-    chunkify [] = []-    chunkify str =-        let (start, rem) = splitAt 1024 str-        in  (B.pack $ map c2w start):chunkify rem--longBL = toBL longDoc--instance NFData B.ByteString where-    rnf bs = ()--myCopy :: B.ByteString -> IO B.ByteString-myCopy (I.PS x s l) = I.create l $ \p -> withForeignPtr x $ \f ->-    I.memcpy p (f `plusPtr` s) (fromIntegral l)--myLCopy :: L.ByteString -> IO L.ByteString-myLCopy bs = do-    let cs = L.toChunks bs-    cs' <- mapM myCopy cs-    return $ L.fromChunks cs'--{--allocateStuff :: IO ()-allocateStuff = do-    x <- forM [1..1000] $ \idx -> return  $ show idx-    rnf x `seq` return ()-    -}--gocrazy descr = forever $ do-    putStrLn descr-    c <- myLCopy longBL-    let sax = parseSAX Nothing c :: [SAXEvent B.ByteString B.ByteString]-    rnf (take 20 sax) `seq` return ()--main = do-    forkIO $ gocrazy "one"-    gocrazy "two"-

@@ -1,25 +0,0 @@--- | Parse to sax events with locations--import Text.XML.Expat.Tree-import Text.XML.Expat.Format-import System.Environment-import System.Exit-import System.IO-import qualified Data.ByteString.Lazy as L--main = do-    args <- getArgs-    case args of-        [filename] -> process filename-        otherwise  -> do-            hPutStrLn stderr "Usage: locations <file.xml>"-            exitWith $ ExitFailure 1--process :: String -> IO ()-process filename = do-    inputText <- L.readFile filename-    -- Note: Because we're not using the tree, Haskell can't infer the type of-    -- strings we're using so we need to tell it explicitly with a type signature.-    let events = parseSAXLocations Nothing inputText :: [(SAXEvent String String, XMLParseLocation)]-    mapM_ print events-

@@ -1,101 +0,0 @@-<?xml version="1.0" encoding="UTF-8"?>-<countries>-  <country category="geo" continent="AS" currency="BDT" languages="bn_BD,en" lat="24.0" long="90.0" name="geo.BD" owner="system" type="geo" tz="Asia/Dhaka">-    <text lang="">Gana Prajatantri Bangladesh</text>-    <text lang="scn">Bangladesci</text>-    <text lang="gd">Bangladesh</text>-    <text lang="ga">An Bhanglaidéis</text>-    <text lang="gl">Bangladesh - বাংলাদেশ</text>-    <text lang="la">Bangladesia</text>-    <text lang="lo">ບັງກະລາເທດ</text>-    <text lang="tr">Bangladeş</text>-    <text lang="li">Bangladesj</text>-    <text lang="lv">Bangladeša</text>-    <text lang="lt">Bangladešas</text>-    <text lang="th">บังคลาเทศ</text>-    <text lang="tg">Бангладеш</text>-    <text lang="te">బంగ్లాదేశ్</text>-    <text lang="ta">பங்களாதேஷ்</text>-    <text lang="de">Bangladesch</text>-    <text lang="da">Bangladesh</text>-    <text lang="dz">བངྒ་ལ་དེཤ</text>-    <text lang="qu">Bangladesh</text>-    <text lang="kn">ಬಾಂಗ್ಲಾದೇಶ</text>-    <text lang="bpy">বাংলাদেশ</text>-    <text lang="el">Μπανγκλαντές</text>-    <text lang="eo">Bangladeŝo</text>-    <text lang="en">Bangladesh</text>-    <text lang="zh">孟加拉国</text>-    <text lang="eu">Bangladesh</text>-    <text lang="et">Bangladesh</text>-    <text lang="es">Bangladesh</text>-    <text lang="ru">Бангладеш</text>-    <text lang="ro">Bangladesh</text>-    <text lang="be">Бангладэш</text>-    <text lang="bg">Бангладеш</text>-    <text lang="ms">Bangladesh</text>-    <text lang="ast">Bangladesh</text>-    <text lang="bn">Gonaoprojatontri Bangladesh</text>-    <text lang="bs">Bangladeš</text>-    <text lang="ja">バングラデシュ</text>-    <text lang="oc">Bangladèsh</text>-    <text lang="nds">Bangladesch</text>-    <text lang="os">Бангладеш</text>-    <text lang="ca">Bangla Desh</text>-    <text lang="cy">Bangladesh</text>-    <text lang="cs">Bangladéš</text>-    <text lang="ps">بنګله‌دیش</text>-    <text lang="pt">Bangladesh</text>-    <text lang="tl">Bangladesh</text>-    <text lang="pl">Bangladesz</text>-    <text lang="hy">Բանգլադեշ</text>-    <text lang="hr">Bangladeš</text>-    <text lang="ht">Bangladèch</text>-    <text lang="hu">Banglades</text>-    <text lang="hi">बंगलादेश</text>-    <text lang="he">בנגלאדש</text>-    <text lang="fur">Bangladesh</text>-    <text lang="ml">ബംഗ്ലാദേശ്</text>-    <text lang="mk">Бангладеш</text>-    <text lang="ur">بنگلہ دیش</text>-    <text lang="mt">Bangladexx</text>-    <text lang="uk">Бангладеш</text>-    <text lang="mr">बांगलादेश</text>-    <text lang="ug">بېنگلا</text>-    <text lang="af">Bangladesj</text>-    <text lang="vi">Bangladesh</text>-    <text lang="is">Bangladess</text>-    <text lang="am">ባንግላዲሽ</text>-    <text lang="it">Bangladesh</text>-    <text lang="an">Bangladesh</text>-    <text lang="ar">بنغلاديش</text>-    <text lang="io">Bangladesh</text>-    <text lang="ia">Bangladesh</text>-    <text lang="id">Bangladesh</text>-    <text lang="ks">बंगलादेश</text>-    <text lang="nl">Bangladesh</text>-    <text lang="nn">Bangladesh</text>-    <text lang="no">Bangladesh</text>-    <text lang="na">Bangladesh</text>-    <text lang="nb">Bangladesh</text>-    <text lang="so">Bangaala-Deesh</text>-    <text lang="pam">Bangladesh</text>-    <text lang="fr">Bangladesh</text>-    <text lang="fy">Banglades</text>-    <text lang="fa">بنگلادش</text>-    <text lang="fi">Bangladesh</text>-    <text lang="fo">Bangladesj</text>-    <text lang="ka">ბანგლადეში</text>-    <text lang="sr">Бангладеш</text>-    <text lang="sq">Bangladeshi</text>-    <text lang="ko">방글라데시</text>-    <text lang="sv">Bangladesh</text>-    <text lang="km">បង់ក្លាដេស្ហ</text>-    <text lang="sk">Bangladéš</text>-    <text lang="sh">Bangladeš</text>-    <text lang="kw">Bangladesh</text>-    <text lang="ku">Bangladeş</text>-    <text lang="sl">Bangladeš</text>-    <text lang="se">Bangladesh</text>-  </country>-</countries>

@@ -1,164 +0,0 @@-import Text.XML.Expat.Tree-import Text.XML.Expat.IO-import Text.XML.Expat.Format-import Text.XML.Expat.Qualified-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as L-import qualified Data.Text as T-import CForeign-import Data.ByteString.Internal (c2w, w2c)-import Data.Char-import Data.Maybe-import Data.IORef-import Control.Applicative-import Control.Exception as E-import Control.Monad-import Control.Parallel.Strategies-import Test.HUnit hiding (Node)-import System.IO--toByteStringL :: String -> L.ByteString-toByteStringL = L.pack . map c2w--fromByteStringL :: L.ByteString -> String-fromByteStringL = map w2c . L.unpack--toByteString :: String -> B.ByteString-toByteString = B.pack . map c2w--fromByteString :: B.ByteString -> String-fromByteString = map w2c . B.unpack--testDoc :: (Show tag, Show text) =>-           (Maybe Encoding -> bs -> Either XMLParseError (Node tag text))-        -> (Node tag text -> L.ByteString)-        -> (String -> bs)-        -> String-        -> Int-        -> String-        -> IO ()-testDoc parse fmt toBS descr0 idx xml = do-  let eTree = parse (Just UTF8) (toBS xml)-      descr = descr0++" #"++show idx-  case eTree of-      Right tree -> do-          let out = fromByteStringL $ fmt tree-          assertEqual descr xml out-      Left error -> do-          hPutStrLn stderr $ "parse failed: "++show error-          assertFailure descr--simpleDocs = [-    "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n"++-    "<test xmlns:abc=\"http://blacksapphire.com/abc\"><abc:test1 type=\"expression\">Cat &amp; mouse</abc:test1><test2 type=\"communication\" language=\"Rhyming slang\">Dog &amp; bone</test2></test>",--    "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n"++-    "<second><test><test1 type=\"expression\">Cat &amp; mouse</test1><test2 type=\"communication\" language=\"Rhyming slang\">Dog &amp; bone</test2></test><test>Rose &amp; Crown</test></second>",--    "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n<test>Cat &amp; mouse</test>"-  ]--eitherify f mEnc bs = do-    case f mEnc bs of-        (_, Just err)  -> Left err-        (doc, Nothing) -> Right doc--test_error1 :: IO ()-test_error1 = do-    let eDoc = parseTree' Nothing (toByteString "<hello></goodbye>") :: Either XMLParseError (UNode String)-    assertEqual "error1" (Left $ XMLParseError "mismatched tag" (XMLParseLocation 1 9 9 0)) eDoc--test_error2 :: IO ()-test_error2 = do-    assertEqual "error2" (-            Element {eName = "hello", eAttrs = [], eChildren = []},-            Just (XMLParseError "mismatched tag" (XMLParseLocation 1 9 9 0))-        ) (parseTree Nothing-              (toByteStringL "<hello></goodbye>") :: (UNode String, Maybe XMLParseError))--test_error3 :: IO ()-test_error3 =-    assertEqual "error3" (-            Element {eName = "open", eAttrs = [], eChildren = [-                Element {eName = "test1", eAttrs = [], eChildren = [Text "Hello"]},-                Element {eName = "hello", eAttrs = [], eChildren = []}-            ]},-            Just (XMLParseError "mismatched tag" (XMLParseLocation 1 35 35 0))-        ) $ parseTree Nothing-              (toByteStringL "<open><test1>Hello</test1><hello></goodbye>")--test_error4 :: IO ()-test_error4 = do-    let eDoc = parseTree' Nothing (toByteString "!") :: Either XMLParseError (UNode String)-    assertEqual "error1" (Left $ XMLParseError "not well-formed (invalid token)"-        (XMLParseLocation 1 0 0 0)) eDoc--test_parse :: IO ()-test_parse = do-    ref <- newIORef []-    let lazy = L.fromChunks [-            toByteString "<open><tes",-            toByteString "t1>Hello</test",-            toByteString "1><hello></he",-            toByteString "llo></open>"]-    parser <- newParser Nothing-    setStartElementHandler parser $ \cname cattrs -> do-        name <- peekCString cname-        ref <- modifyIORef ref $ \l -> ("start "++name):l-        return True-    setEndElementHandler parser $ \cname -> do-        name <- peekCString cname-        ref <- modifyIORef ref $ \l -> ("end "++name):l-        return True-    parse parser lazy-    l <- reverse <$> readIORef ref-    assertEqual "parse"-        ["start open","start test1","end test1","start hello","end hello","end open"]-        l--test_textContent = do-    let tree = Element "cheese" [("type", "edam")]-            [Text "You don't actually ",-             Element "sub" [] [Text "have any "],-             Text "cheese at all",-             Text ", do you?"]-    assertEqual "textContent" "You don't actually have any cheese at all, do you?" (textContent tree)--main = do-    testXML <- map w2c . B.unpack <$> B.readFile "test.xml"-    -- Remove trailing newline-    let testXML' = reverse . dropWhile (== '\n') . reverse $ testXML-        docs = simpleDocs ++ [testXML']-        t (descr, parse, fmt) = do-            forM_ (zip [1..] docs) $ \(idx, doc) ->-                testDoc parse fmt toByteStringL descr idx doc-        t' (descr, parse, fmt) = do-            forM_ (zip [1..] docs) $ \(idx, doc) ->-                testDoc parse fmt toByteString descr idx doc-    runTestTT $ TestList [-        TestCase $ t' ("String",-            parseTree' :: Maybe Encoding -> B.ByteString -> Either XMLParseError (Node String String),-            formatTree),-        TestCase $ t' ("ByteString",-            parseTree' :: Maybe Encoding -> B.ByteString -> Either XMLParseError (Node B.ByteString B.ByteString),-            formatTree),-        TestCase $ t' ("Text",-            parseTree' :: Maybe Encoding -> B.ByteString -> Either XMLParseError (Node T.Text T.Text),-            formatTree),-        TestCase $ t ("String/Lazy",-            eitherify $ parseTree :: Maybe Encoding -> L.ByteString -> Either XMLParseError (Node String String),-            formatTree),-        TestCase $ t ("ByteString/Lazy",-            eitherify $ parseTree :: Maybe Encoding -> L.ByteString -> Either XMLParseError (Node B.ByteString B.ByteString),-            formatTree),-        TestCase $ t ("Text/Lazy",-            eitherify $ parseTree :: Maybe Encoding -> L.ByteString -> Either XMLParseError (Node T.Text T.Text),-            formatTree),-        TestCase $ test_error1,-        TestCase $ test_error2,-        TestCase $ test_error3,-        TestCase $ test_error4,-        TestCase $ test_parse,-        TestCase $ test_textContent-      ]-