hexpat 0.3 → 0.4

raw patch · 16 files changed

+1158/−607 lines, 16 filesdep +binarydep +mtldep +parallelPVP ok

version bump matches the API change (PVP)

Dependencies added: binary, mtl, parallel, text, utf8-string

API changes (from Hackage documentation)

Files

• C2HS.hs +0/−220
• Text/XML/Expat/Format.hs +79/−42
• Text/XML/Expat/IO.chs +0/−196
• Text/XML/Expat/IO.hs +300/−0
• Text/XML/Expat/Qualified.hs +124/−0
• Text/XML/Expat/Tree.hs +219/−32
• hexpat.cabal +45/−15
• perf.hs +0/−42
• test.hs +0/−31
• test/benchmark.hs +79/−0
• test/lazySAX.hs +25/−0
• test/lazyTree.hs +25/−0
• test/perf.hs +42/−0
• test/test.xml +101/−0
• test/tests.hs +119/−0
• test2.hs +0/−29

@@ -1,220 +0,0 @@---  C->Haskell Compiler: Marshalling library------  Copyright (c) [1999...2005] Manuel M T Chakravarty------  Redistribution and use in source and binary forms, with or without---  modification, are permitted provided that the following conditions are met:--- ---  1. Redistributions of source code must retain the above copyright notice,---     this list of conditions and the following disclaimer. ---  2. Redistributions in binary form must reproduce the above copyright---     notice, this list of conditions and the following disclaimer in the---     documentation and/or other materials provided with the distribution. ---  3. The name of the author may not be used to endorse or promote products---     derived from this software without specific prior written permission. ------  THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR---  IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES---  OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN---  NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ---  SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED---  TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR---  PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF---  LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING---  NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS---  SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.------- Description ---------------------------------------------------------------------  Language: Haskell 98------  This module provides the marshaling routines for Haskell files produced by ---  C->Haskell for binding to C library interfaces.  It exports all of the---  low-level FFI (language-independent plus the C-specific parts) together---  with the C->HS-specific higher-level marshalling routines.-----module C2HS (--  -- * Re-export the language-independent component of the FFI -  module Foreign,--  -- * Re-export the C language component of the FFI-  module CForeign,--  -- * Composite marshalling functions-  withCStringLenIntConv, peekCStringLenIntConv, withIntConv, withFloatConv,-  peekIntConv, peekFloatConv, withBool, peekBool, withEnum, peekEnum,--  -- * Conditional results using 'Maybe'-  nothingIf, nothingIfNull,--  -- * Bit masks-  combineBitMasks, containsBitMask, extractBitMasks,--  -- * Conversion between C and Haskell types-  cIntConv, cFloatConv, cToBool, cFromBool, cToEnum, cFromEnum-) where ---import Foreign-       hiding       (Word)-		    -- Should also hide the Foreign.Marshal.Pool exports in-		    -- compilers that export them-import CForeign--import Monad        (when, liftM)----- Composite marshalling functions--- ----------------------------------- Strings with explicit length----withCStringLenIntConv s f    = withCStringLen s $ \(p, n) -> f (p, cIntConv n)-peekCStringLenIntConv (s, n) = peekCStringLen (s, cIntConv n)---- Marshalling of numerals-----withIntConv   :: (Storable b, Integral a, Integral b) -	      => a -> (Ptr b -> IO c) -> IO c-withIntConv    = with . cIntConv--withFloatConv :: (Storable b, RealFloat a, RealFloat b) -	      => a -> (Ptr b -> IO c) -> IO c-withFloatConv  = with . cFloatConv--peekIntConv   :: (Storable a, Integral a, Integral b) -	      => Ptr a -> IO b-peekIntConv    = liftM cIntConv . peek--peekFloatConv :: (Storable a, RealFloat a, RealFloat b) -	      => Ptr a -> IO b-peekFloatConv  = liftM cFloatConv . peek---- Passing Booleans by reference-----withBool :: (Integral a, Storable a) => Bool -> (Ptr a -> IO b) -> IO b-withBool  = with . fromBool--peekBool :: (Integral a, Storable a) => Ptr a -> IO Bool-peekBool  = liftM toBool . peek----- Passing enums by reference-----withEnum :: (Enum a, Integral b, Storable b) => a -> (Ptr b -> IO c) -> IO c-withEnum  = with . cFromEnum--peekEnum :: (Enum a, Integral b, Storable b) => Ptr b -> IO a-peekEnum  = liftM cToEnum . peek----- Storing of 'Maybe' values--- ---------------------------instance Storable a => Storable (Maybe a) where-  sizeOf    _ = sizeOf    (undefined :: Ptr ())-  alignment _ = alignment (undefined :: Ptr ())--  peek p = do-	     ptr <- peek (castPtr p)-	     if ptr == nullPtr-	       then return Nothing-	       else liftM Just $ peek ptr--  poke p v = do-	       ptr <- case v of-		        Nothing -> return nullPtr-			Just v' -> new v'-               poke (castPtr p) ptr----- Conditional results using 'Maybe'--- ------------------------------------- Wrap the result into a 'Maybe' type.------ * the predicate determines when the result is considered to be non-existing,---   ie, it is represented by `Nothing'------ * the second argument allows to map a result wrapped into `Just' to some---   other domain----nothingIf       :: (a -> Bool) -> (a -> b) -> a -> Maybe b-nothingIf p f x  = if p x then Nothing else Just $ f x---- |Instance for special casing null pointers.----nothingIfNull :: (Ptr a -> b) -> Ptr a -> Maybe b-nothingIfNull  = nothingIf (== nullPtr)----- Support for bit masks--- ------------------------- Given a list of enumeration values that represent bit masks, combine these--- masks using bitwise disjunction.----combineBitMasks :: (Enum a, Bits b) => [a] -> b-combineBitMasks = foldl (.|.) 0 . map (fromIntegral . fromEnum)---- Tests whether the given bit mask is contained in the given bit pattern--- (i.e., all bits set in the mask are also set in the pattern).----containsBitMask :: (Bits a, Enum b) => a -> b -> Bool-bits `containsBitMask` bm = let bm' = fromIntegral . fromEnum $ bm-			    in-			    bm' .&. bits == bm'---- |Given a bit pattern, yield all bit masks that it contains.------ * This does *not* attempt to compute a minimal set of bit masks that when---   combined yield the bit pattern, instead all contained bit masks are---   produced.----extractBitMasks :: (Bits a, Enum b, Bounded b) => a -> [b]-extractBitMasks bits = -  [bm | bm <- [minBound..maxBound], bits `containsBitMask` bm]----- Conversion routines--- ----------------------- |Integral conversion----cIntConv :: (Integral a, Integral b) => a -> b-cIntConv  = fromIntegral---- |Floating conversion----cFloatConv :: (RealFloat a, RealFloat b) => a -> b-cFloatConv  = realToFrac--- As this conversion by default goes via `Rational', it can be very slow...-{-# RULES -  "cFloatConv/Float->Float"   forall (x::Float).  cFloatConv x = x;-  "cFloatConv/Double->Double" forall (x::Double). cFloatConv x = x- #-}---- |Obtain C value from Haskell 'Bool'.----cFromBool :: Num a => Bool -> a-cFromBool  = fromBool---- |Obtain Haskell 'Bool' from C value.----cToBool :: Num a => a -> Bool-cToBool  = toBool---- |Convert a C enumeration to Haskell.----cToEnum :: (Integral i, Enum e) => i -> e-cToEnum  = toEnum . cIntConv---- |Convert a Haskell enumeration to C.----cFromEnum :: (Enum e, Integral i) => e -> i-cFromEnum  = cIntConv . fromEnum

@@ -1,54 +1,91 @@+-- 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 lazy functions to format a tree+-- structure as UTF-8 encoded XML.++{-# LANGUAGE FlexibleContexts #-}+ module Text.XML.Expat.Format (-        formatDoc,-        formatDocS,+        formatTree,         formatNode,-        formatNodeS+        putTree,+        putNode     ) where  import Text.XML.Expat.IO import Text.XML.Expat.Tree--enc :: String -> String-enc = id+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import Data.ByteString.Internal (c2w, w2c)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import Data.Binary.Put+import Control.Monad  -- | Format document with <?xml.. header.-formatDoc :: Maybe Encoding -> Node -> String-formatDoc mEnc node = formatDocS mEnc node ""+formatTree :: TreeFlavor tag text+           -> Node tag text+           -> L.ByteString+formatTree flavour node = runPut $ putTree flavour node --- | Format document with <?xml.. header returning as a ShowS.-formatDocS :: Maybe Encoding -> Node -> ShowS-formatDocS mEnc node = ("<?xml version=\"1.0\""++) . putEnc mEnc . ("?>\n"++) . formatNodeS node-    where-        putEnc (Just enc) = (" encoding=\""++) . (encodingToString enc++) . ("\""++)-        putEnc Nothing = id+-- | Format XML node with no header.+formatNode :: TreeFlavor tag text+           -> Node tag text+           -> L.ByteString+formatNode flavour node = runPut $ putNode flavour node --- | Format XML node with no XML header.-formatNode :: Node -> String-formatNode node = formatNodeS node ""+-- | 'Data.Binary.Put.Put' interface for formatting a tree with <?xml.. header.+putTree :: TreeFlavor tag text+        -> Node tag text+        -> Put+putTree flavour node = do+    putByteString $ pack "<?xml version=\"1.0\""+    putByteString $ pack " encoding=\"UTF-8\""+    putByteString $ pack "?>\n"+    putNode flavour node --- | Format XML node with no XML header returning as a ShowS.-formatNodeS :: Node -> ShowS-formatNodeS (Element name attrs children) =-    ("<"++) . (enc name++) .-    foldr (.) id (flip map attrs (\(name, value) ->-            (" "++) . (enc name++) . ("=\""++) .-                     (enc (escapeXML value)++) . ("\""++) -        )) .-    (if null children-            then-                ("/>"++)-            else-                (">"++) .-                foldr (.) id (map formatNodeS children) .-                ("</"++) . (enc name++) . (">"++)-        )-formatNodeS (Text txt) = (enc (escapeXML txt)++)+-- | 'Data.Binary.Put.Put' interface for formatting a node with no header.+putNode :: TreeFlavor tag text+           -> Node tag text+           -> Put+putNode flavour@(TreeFlavor _ _ putTag fmtText) (Element name attrs children) = do+    putWord8 $ c2w '<'+    let putThisTag = putTag name+    putThisTag+    forM_ attrs $ \(aname, avalue) -> do+        putWord8 $ c2w ' '+        putTag aname+        putByteString $ pack "=\""+        putXMLText $ fmtText avalue+        putByteString $ pack "\"" +    if null children+        then+            putByteString $ pack "/>"+        else do+            putWord8 $ c2w '>'+            forM_ children $ putNode flavour+            putByteString $ pack "</"+            putThisTag+            putWord8 $ c2w '>'+putNode (TreeFlavor _ _ putTag fmtText) (Text txt) =+    putXMLText $ fmtText txt -escapeXML :: String -> String-escapeXML = concatMap e-    where-        e '&' = "&amp;"-        e '<' = "&lt;"-        e '"' = "&quot;"-        e '\'' = "&apos;"-        e ch = [ch]+pack :: String -> B.ByteString+pack = B.pack . map c2w++unpack :: L.ByteString -> String+unpack = map w2c . L.unpack++putXMLText :: B.ByteString -> Put+putXMLText str | B.null str = return ()+putXMLText str = do+    case w2c $ B.head str of+        '&'  -> putByteString $ pack "&amp;"+        '<'  -> putByteString $ pack "&lt;"+        '"'  -> putByteString $ pack "&quot;"+        '\'' -> putByteString $ pack "&apos;"+        ch   -> putWord8 (c2w ch)+    putXMLText $ B.tail str+

@@ -1,196 +0,0 @@--- hexpat, a Haskell wrapper for expat--- Copyright (C) 2008 Evan Martin <martine@danga.com>---- |This module wraps the Expat API directly with IO operations--- everywhere.  Basic usage is:------ (1) Make a new parser: 'newParser'.------ (2) Set up callbacks on the parser: 'setStartElementHandler', etc.------ (3) Feed data into the parser: 'parse' or 'parseChunk'.--module Text.XML.Expat.IO (-  -- ** Parser Setup-  Parser, newParser,--  -- ** Parsing-  parse, Encoding(..),--  -- ** Parser Callbacks-  StartElementHandler, EndElementHandler, CharacterDataHandler,-  setStartElementHandler, setEndElementHandler, setCharacterDataHandler,--  -- ** Lower-level Parsing Interface-  parseChunk,--  -- ** Helpers-  encodingToString-) where--import Control.Exception (bracket)-import C2HS-import qualified Data.ByteString as BS-import qualified Data.ByteString.Lazy as BSL-import Data.IORef--#include <expat.h>---- Expat functions start with "XML", but C2HS appears to ignore our "as"--- definitions if they only differ from the symbol in case.  So we write out--- XML_* in most cases anyway...  :(-{#context lib = "expat" prefix = "XML"#}---- |Opaque parser type.-type ParserPtr = Ptr ()-data Parser = Parser-    (ForeignPtr ())-    (IORef CStartElementHandler) -    (IORef CEndElementHandler) -    (IORef CCharacterDataHandler) --withParser :: Parser -> (ParserPtr -> IO a) -> IO a-withParser (Parser fp _ _ _) = withForeignPtr fp---- |Encoding types available for the document encoding.-data Encoding = ASCII | UTF8 | UTF16 | ISO88591-encodingToString :: Encoding -> String-encodingToString ASCII    = "US-ASCII"-encodingToString UTF8     = "UTF-8"-encodingToString UTF16    = "UTF-16"-encodingToString ISO88591 = "ISO-8859-1"--withOptEncoding :: Maybe Encoding -> (CString -> IO a) -> IO a-withOptEncoding Nothing    f = f nullPtr-withOptEncoding (Just enc) f = withCString (encodingToString enc) f--{#fun unsafe XML_ParserCreate as parserCreate-    {withOptEncoding* `Maybe Encoding'} -> `ParserPtr' id#}-foreign import ccall "&XML_ParserFree" parserFree :: FunPtr (ParserPtr -> IO ())---- |Create a 'Parser'.  The encoding parameter, if provided, overrides the--- document's encoding declaration.-newParser :: Maybe Encoding -> IO Parser-newParser enc = do-  ptr <- parserCreate enc-  fptr <- newForeignPtr parserFree ptr-  nullStartH <- newIORef nullCStartElementHandler-  nullEndH <- newIORef nullCEndElementHandler-  nullCharH <- newIORef nullCCharacterDataHandler-  return $ Parser fptr nullStartH nullEndH nullCharH---- 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-withBStringLen bs f = do-  BS.useAsCStringLen bs $ \(str, len) -> f (str, fromIntegral len)--unStatus :: CInt -> Bool-unStatus 0 = False-unStatus 1 = True--- |@parseChunk data False@ feeds /strict/ ByteString data into a--- 'Parser'.  The end of the data is indicated by passing @True@ for the--- final parameter.  @parse@ returns @False@ on a parse error.-parseChunk :: Parser-              -> BS.ByteString-              -> Bool-              -> IO Bool-parseChunk parser@(Parser fp startRef endRef charRef) xml final = do-    bracket-        (do-            cStartH <- mkCStartElementHandler =<< readIORef startRef-            cEndH   <- mkCEndElementHandler =<< readIORef endRef-            cCharH  <- mkCCharacterDataHandler =<< readIORef charRef-            withParser parser $ \p -> do-                {#call unsafe XML_SetStartElementHandler as ^#}  p cStartH-                {#call unsafe XML_SetEndElementHandler as ^#}    p cEndH-                {#call unsafe XML_SetCharacterDataHandler as ^#} p cCharH-            return (cStartH, cEndH, cCharH))-        (\(cStartH, cEndH, cCharH) -> do-            freeHaskellFunPtr cStartH-            freeHaskellFunPtr cEndH-            freeHaskellFunPtr cCharH)-        (\_ -> doParseChunk parser xml final)--{#fun XML_Parse as doParseChunk-    {withParser* `Parser', withBStringLen* `BS.ByteString' &, `Bool'}-    -> `Bool' unStatus#}---- |@parse data@ feeds /lazy/ bytestring data into a parser and returns--- @True@ if there was no parse error.-parse :: Parser -> BSL.ByteString -> IO Bool-parse parser bs = feedChunk (BSL.toChunks bs) where-  feedChunk []      = return True-  feedChunk [chunk] = parseChunk parser chunk True-  feedChunk (c:cs)  = do ok <- parseChunk parser c False-                         if ok then feedChunk cs-                               else return False---- |The type of the \"element started\" callback.  The first parameter is--- the element name; the second are the (attribute, value) pairs.-type StartElementHandler  = String -> [(String,String)] -> IO ()--- |The type of the \"element ended\" callback.  The parameter is--- the element name.-type EndElementHandler    = String -> IO ()--- |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.-type CharacterDataHandler = String -> IO ()--type CStartElementHandler = Ptr () -> CString -> Ptr CString -> IO ()-nullCStartElementHandler _ _ _ = return ()--foreign import ccall "wrapper"-  mkCStartElementHandler :: CStartElementHandler-                         -> IO (FunPtr CStartElementHandler)-wrapStartElementHandler :: StartElementHandler -> CStartElementHandler-wrapStartElementHandler handler = h where-  h ptr cname cattrs = do-    name <- peekCString cname-    cattrlist <- peekArray0 nullPtr cattrs-    attrlist <- mapM peekCString cattrlist-    handler name (pairwise attrlist)--- |Attach a StartElementHandler to a Parser.-setStartElementHandler :: Parser -> StartElementHandler -> IO ()-setStartElementHandler parser@(Parser _ startRef _ _) handler = do-  withParser parser $ \p -> do-  writeIORef startRef $ wrapStartElementHandler handler---type CEndElementHandler = Ptr () -> CString -> IO ()-nullCEndElementHandler _ _ = return ()--foreign import ccall "wrapper"-  mkCEndElementHandler :: CEndElementHandler-                       -> IO (FunPtr CEndElementHandler)-wrapEndElementHandler :: EndElementHandler -> CEndElementHandler-wrapEndElementHandler handler = h where-  h ptr cname = do-    name <- peekCString cname-    handler name---- |Attach an EndElementHandler to a Parser.-setEndElementHandler :: Parser -> EndElementHandler -> IO ()-setEndElementHandler parser@(Parser _ _ endRef _) handler = do-  withParser parser $ \p -> do-  writeIORef endRef $ wrapEndElementHandler handler--type CCharacterDataHandler = Ptr () -> CString -> CInt -> IO ()-nullCCharacterDataHandler _ _ _ = return ()--foreign import ccall "wrapper"-  mkCCharacterDataHandler :: CCharacterDataHandler-                          -> IO (FunPtr CCharacterDataHandler)-wrapCharacterDataHandler :: CharacterDataHandler -> CCharacterDataHandler-wrapCharacterDataHandler handler = h where-  h ptr cdata len = do-    data_ <- peekCStringLen (cdata, fromIntegral len)-    handler data_--- |Attach an CharacterDataHandler to a Parser.-setCharacterDataHandler :: Parser -> CharacterDataHandler -> IO ()-setCharacterDataHandler parser@(Parser _ _ _ charRef) handler = do-  withParser parser $ \p -> do-  writeIORef charRef $ wrapCharacterDataHandler handler--pairwise (x1:x2:xs) = (x1,x2) : pairwise xs-pairwise []         = []

@@ -0,0 +1,300 @@+-- hexpat, a Haskell wrapper for expat+-- Copyright (C) 2008 Evan Martin <martine@danga.com>+-- Copyright (C) 2009 Stephen Blackheath <http://blacksapphire.com/antispam>++-- | Low-level interface to Expat. Unless speed is paramount, this+-- should normally be avoided in favour of the interface provided by "Text-XML-Expat-Tree".+-- Basic usage is:+--+-- (1) Make a new parser: 'newParser'.+--+-- (2) Set up callbacks on the parser: 'setStartElementHandler', etc.+--+-- (3) Feed data into the parser: 'parse' or 'parseChunk'.++module Text.XML.Expat.IO (+  -- ** Parser Setup+  Parser, newParser,++  -- ** Parsing+  parse, parseChunk, Encoding(..), XMLParseError(..),++  -- ** Parser Callbacks+  StartElementHandler, EndElementHandler, CharacterDataHandler,+  setStartElementHandler, setEndElementHandler, setCharacterDataHandler,++  -- ** Lower-level interface+  unsafeParseChunk,+  withHandlers,+  unsafeSetHandlers,+  unsafeReleaseHandlers,+  ExpatHandlers,++  -- ** Helpers+  encodingToString+) where++import Control.Exception (bracket)+import Control.Parallel.Strategies+import Control.Monad+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL+import qualified Data.ByteString.Internal as BSI+import Data.IORef+import Foreign+import CForeign+++-- |Opaque parser type.+type ParserPtr = Ptr ()+data Parser = Parser+    (ForeignPtr ())+    (IORef CStartElementHandler) +    (IORef CEndElementHandler) +    (IORef CCharacterDataHandler)++instance Show Parser where+    showsPrec _ (Parser fp _ _ _) = showsPrec 0 fp++withParser :: Parser -> (ParserPtr -> IO a) -> IO a+withParser (Parser fp _ _ _) = withForeignPtr fp++-- |Encoding types available for the document encoding.+data Encoding = ASCII | UTF8 | UTF16 | ISO88591+encodingToString :: Encoding -> String+encodingToString ASCII    = "US-ASCII"+encodingToString UTF8     = "UTF-8"+encodingToString UTF16    = "UTF-16"+encodingToString ISO88591 = "ISO-8859-1"++withOptEncoding :: Maybe Encoding -> (CString -> IO a) -> IO a+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.+newParser :: Maybe Encoding -> IO Parser+newParser enc = do+  ptr <- parserCreate enc+  fptr <- newForeignPtr parserFree ptr+  nullStartH <- newIORef nullCStartElementHandler+  nullEndH <- newIORef nullCEndElementHandler+  nullCharH <- newIORef nullCCharacterDataHandler+  return $ Parser fptr nullStartH nullEndH nullCharH++-- 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+withBStringLen bs f = do+  BS.useAsCStringLen bs $ \(str, len) -> f (str, fromIntegral len)++unStatus :: CInt -> Bool+unStatus 0 = False+unStatus 1 = True++-- |@parse data@ feeds /lazy/ 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+    ok <- doParseChunk parser bs True+    if ok+        then return Nothing+        else Just `fmap` getError parser++-- |@parseChunk data False@ feeds /strict/ ByteString data into a+-- 'Parser'.  The end of the data is indicated by passing @True@ for the+-- final parameter.   It returns Nothing on success, or Just the parse error.+parseChunk :: Parser+           -> BS.ByteString+           -> Bool+           -> 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.+unsafeParseChunk :: Parser+           -> BS.ByteString+           -> Bool+           -> IO (Maybe XMLParseError)+unsafeParseChunk parser xml final = do+    ok <- doParseChunk parser xml final+    if ok+        then return Nothing+        else Just `fmap` getError parser++getError parser = withParser parser $ \p -> do+                code <- xmlGetErrorCode p+                cerr <- xmlErrorString code+                err <- peekCString cerr+                line <- xmlGetCurrentLineNumber p+                col <- xmlGetCurrentColumnNumber p+                return $ XMLParseError err+                    (fromIntegral line) (fromIntegral col)++data ExpatHandlers = ExpatHandlers+    (FunPtr CStartElementHandler)+    (FunPtr CEndElementHandler)+    (FunPtr CCharacterDataHandler)++unsafeSetHandlers :: Parser -> IO ExpatHandlers+unsafeSetHandlers parser@(Parser fp startRef endRef charRef) = do+    cStartH <- mkCStartElementHandler =<< readIORef startRef+    cEndH   <- mkCEndElementHandler =<< readIORef endRef+    cCharH  <- mkCCharacterDataHandler =<< readIORef charRef+    withParser parser $ \p -> do+        xmlSetstartelementhandler  p cStartH+        xmlSetendelementhandler    p cEndH+        xmlSetcharacterdatahandler p cCharH+    return $ ExpatHandlers cStartH cEndH cCharH++unsafeReleaseHandlers :: ExpatHandlers -> IO ()+unsafeReleaseHandlers (ExpatHandlers cStartH cEndH cCharH) = do+    freeHaskellFunPtr cStartH+    freeHaskellFunPtr cEndH+    freeHaskellFunPtr cCharH++-- | 'unsafeParseChunk' is required to be called inside @withHandlers@.+-- Safer than using 'unsafeSetHandlers' / 'unsafeReleaseHandlers'.+withHandlers :: Parser+             -> IO a  -- ^ Computation where unsafeParseChunk may be used+             -> IO a+withHandlers parser code = do+    bracket+        (unsafeSetHandlers parser)+        unsafeReleaseHandlers+        (\_ -> code)++-- |Obtain C value from Haskell 'Bool'.+--+cFromBool :: Num a => Bool -> a+cFromBool  = fromBool++doParseChunk :: Parser -> BS.ByteString -> Bool -> IO (Bool)+doParseChunk a1 a2 a3 =+  withParser a1 $ \a1' -> +  withBStringLen a2 $ \(a2'1, a2'2) -> +  let {a3' = cFromBool a3} in +  doParseChunk'_ a1' a2'1  a2'2 a3' >>= \res ->+  let {res' = unStatus res} in+  return (res')++-- | Parse error, consisting of message text, line number, and column number+data XMLParseError = XMLParseError String Integer Integer deriving (Eq, Show)++instance NFData XMLParseError where+    rnf (XMLParseError msg lin col) = rnf (msg, lin, col)++-- |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.+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+-- parsing as normal, or False to terminate the parse.+type CharacterDataHandler = CStringLen -> IO Bool++type CStartElementHandler = Ptr () -> CString -> Ptr CString -> IO ()+nullCStartElementHandler _ _ _ = return ()++foreign import ccall unsafe "expat.h XML_GetErrorCode" xmlGetErrorCode+    :: ParserPtr -> IO CInt+foreign import ccall unsafe "expat.h XML_GetCurrentLineNumber" xmlGetCurrentLineNumber+    :: ParserPtr -> IO CUInt  -- to do: Get 64-bit value if supported (how?)+foreign import ccall unsafe "expat.h XML_GetCurrentColumnNumber" xmlGetCurrentColumnNumber+    :: ParserPtr -> IO CUInt  -- to do: Get 64-bit value if supported (how?)+foreign import ccall unsafe "expat.h XML_ErrorString" xmlErrorString+    :: CInt -> IO CString+foreign import ccall unsafe "expat.h XML_StopParser" xmlStopParser+    :: ParserPtr -> CInt -> IO ()++foreign import ccall safe "wrapper"+  mkCStartElementHandler :: CStartElementHandler+                         -> IO (FunPtr CStartElementHandler)++wrapStartElementHandler :: Parser -> StartElementHandler -> CStartElementHandler+wrapStartElementHandler parser@(Parser _ _ _ _) handler = h+  where+    h ptr cname cattrs = do+        cattrlist <- peekArray0 nullPtr cattrs+        stillRunning <- handler cname (pairwise cattrlist)+        unless stillRunning $+            withParser parser $ \p -> xmlStopParser p 0 ++-- |Attach a StartElementHandler to a Parser.+setStartElementHandler :: Parser -> StartElementHandler -> IO ()+setStartElementHandler parser@(Parser _ startRef _ _) handler =+    withParser parser $ \p -> do+        writeIORef startRef $ wrapStartElementHandler parser handler++type CEndElementHandler = Ptr () -> CString -> IO ()+nullCEndElementHandler _ _ = return ()++foreign import ccall safe "wrapper"+  mkCEndElementHandler :: CEndElementHandler+                       -> IO (FunPtr CEndElementHandler)+wrapEndElementHandler :: Parser -> EndElementHandler -> CEndElementHandler+wrapEndElementHandler parser@(Parser _ _ _ _) handler = h+  where+    h ptr cname = do+        stillRunning <- handler cname+        unless stillRunning $+            withParser parser $ \p -> xmlStopParser p 0 ++-- |Attach an EndElementHandler to a Parser.+setEndElementHandler :: Parser -> EndElementHandler -> IO ()+setEndElementHandler parser@(Parser _ _ endRef _) handler =+    withParser parser $ \p -> do+        writeIORef endRef $ wrapEndElementHandler parser handler++type CCharacterDataHandler = Ptr () -> CString -> CInt -> IO ()+nullCCharacterDataHandler _ _ _ = return ()++foreign import ccall safe "wrapper"+  mkCCharacterDataHandler :: CCharacterDataHandler+                          -> IO (FunPtr CCharacterDataHandler)+wrapCharacterDataHandler :: Parser -> CharacterDataHandler -> CCharacterDataHandler+wrapCharacterDataHandler parser@(Parser _ _ _ _) handler = h+  where+    h ptr cdata len = do+        stillRunning <- handler (cdata, fromIntegral len)+        unless stillRunning $+            withParser parser $ \p -> xmlStopParser p 0 ++-- | Attach an CharacterDataHandler to a Parser.+setCharacterDataHandler :: Parser -> CharacterDataHandler -> IO ()+setCharacterDataHandler parser@(Parser _ _ _ charRef) handler =+    withParser parser $ \p -> do+        writeIORef charRef $ wrapCharacterDataHandler parser handler++pairwise (x1:x2:xs) = (x1,x2) : pairwise xs+pairwise []         = []+++foreign import ccall unsafe "Text/XML/Expat/IO.chs.h XML_ParserCreate"+  parserCreate'_ :: ((Ptr CChar) -> (IO (Ptr ())))++foreign import ccall unsafe "Text/XML/Expat/IO.chs.h XML_SetStartElementHandler"+  xmlSetstartelementhandler :: ((Ptr ()) -> ((FunPtr ((Ptr ()) -> ((Ptr CChar) -> ((Ptr (Ptr CChar)) -> (IO ()))))) -> (IO ())))++foreign import ccall unsafe "Text/XML/Expat/IO.chs.h XML_SetEndElementHandler"+  xmlSetendelementhandler :: ((Ptr ()) -> ((FunPtr ((Ptr ()) -> ((Ptr CChar) -> (IO ())))) -> (IO ())))++foreign import ccall unsafe "Text/XML/Expat/IO.chs.h XML_SetCharacterDataHandler"+  xmlSetcharacterdatahandler :: ((Ptr ()) -> ((FunPtr ((Ptr ()) -> ((Ptr CChar) -> (CInt -> (IO ()))))) -> (IO ())))++foreign import ccall safe "Text/XML/Expat/IO.chs.h XML_Parse"+  doParseChunk'_ :: ((Ptr ()) -> ((Ptr CChar) -> (CInt -> (CInt -> (IO CInt)))))

@@ -0,0 +1,124 @@+-- hexpat, a Haskell wrapper for expat+-- Copyright (C) 2008 Evan Martin <martine@danga.com>+-- Copyright (C) 2009 Stephen Blackheath <http://blacksapphire.com/antispam>++-- | With the default flavors for 'Text.XML.Expat.Tree.parseTree' and+-- 'Text.XML.Expat.Format.formatTree', qualified tag and attribute names such as+-- \<abc:hello\> are represented just as a string containing a colon, e.g.+-- \"abc:hello\".+--+-- This module provides flavors that handle these more intelligently, splitting+-- all tag and attribute names into their Prefix and LocalPart components.++module Text.XML.Expat.Qualified (+        QName(..),+        mkQName,+        mkAnName,+        qualifiedStringFlavor,+        qualifiedByteStringFlavor,+        qualifiedTextFlavor+    ) where++import Text.XML.Expat.IO+import Text.XML.Expat.Tree+import Text.XML.Expat.Format+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Internal as I+import Data.ByteString.Internal (c2w, w2c)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import Control.Applicative+import Control.Monad.Writer+import Control.Parallel.Strategies+import Data.Monoid+import Data.Binary.Put+import qualified Codec.Binary.UTF8.String as U8+import Foreign.C.String+import Foreign.Ptr+++data QName text =+    QName {+        qnPrefix    :: Maybe text,+        qnLocalPart :: !text+    }+    deriving (Eq,Show)++instance NFData text => NFData (QName text) where+    rnf (QName pre loc) = rnf (pre, loc)++-- | Make a new QName from a prefix and localPart.+mkQName :: text -> text -> QName text+mkQName prefix localPart = QName (Just prefix) localPart++-- | Make a new QName with no prefix.+mkAnName :: text -> QName text+mkAnName localPart = QName Nothing localPart++-- | Flavor for qualified tags, using String data type.+qualifiedStringFlavor :: TreeFlavor (QName String) String+qualifiedStringFlavor = TreeFlavor (\t -> toQName <$> unpack t) unpackLen fromQName pack+  where+    unpack    cstr = U8.decodeString <$> peekCString cstr+    unpackLen cstr = U8.decodeString <$> peekCStringLen cstr+    toQName ident =+        case break (== ':') ident of+            (prefix, ':':local) -> QName (Just prefix) local+            otherwise           -> QName Nothing ident+    pack = B.pack . map c2w . U8.encodeString+    fromQName (QName (Just prefix) local) = do+        mapM_ (putWord8 . c2w) prefix+        putWord8 $ c2w ':'+        mapM_ (putWord8 . c2w) local+    fromQName (QName Nothing local) = mapM_ (putWord8 . c2w) local++-- | Flavor for qualified tags, using ByteString data type, containing UTF-8 encoded Unicode.+qualifiedByteStringFlavor :: TreeFlavor (QName B.ByteString) B.ByteString+qualifiedByteStringFlavor = TreeFlavor (\t -> toQName <$> unpack t) unpackLen fromQName id+  where+    unpack    cstr = peekByteString cstr+    unpackLen cstr = peekByteStringLen cstr+    toQName ident =+        case B.break (== c2w ':') ident of+            (prefix, _local) | not (B.null _local) && B.head _local == c2w ':' ->+                                   QName (Just prefix) (B.tail _local)+            otherwise           -> QName Nothing ident+    fromQName (QName (Just prefix) local) = do+        putByteString prefix+        putWord8 $ c2w ':'+        putByteString local+    fromQName (QName Nothing local) = putByteString local+    colon = B.singleton (c2w ':')++-- | Flavor for qualified tags, using Text data type.+qualifiedTextFlavor :: TreeFlavor (QName T.Text) T.Text+qualifiedTextFlavor = TreeFlavor (\t -> toQName <$> unpack t) unpackLen fromQName TE.encodeUtf8+  where+    unpack    cstr = TE.decodeUtf8 <$> peekByteString cstr+    unpackLen cstr = TE.decodeUtf8 <$> peekByteStringLen cstr+    toQName ident =+        case T.break (== ':') ident of+            (prefix, _local) | not (T.null _local) && T.head _local == ':' ->+                                   QName (Just prefix) (T.tail _local)+            otherwise           -> QName Nothing ident+    fromQName (QName (Just prefix) local) = do+        putByteString . TE.encodeUtf8 $ prefix+        putWord8 $ c2w ':'+        putByteString . TE.encodeUtf8 $ local+    fromQName (QName Nothing local) = putByteString . TE.encodeUtf8 $ local+    colon = T.singleton ':'++peekByteString :: CString -> IO B.ByteString+{-# INLINE peekByteString #-}+peekByteString cstr = do+    len <- I.c_strlen cstr+    peekByteStringLen (castPtr cstr, fromIntegral len)++peekByteStringLen :: CStringLen -> IO B.ByteString +{-# INLINE peekByteStringLen #-}+peekByteStringLen (cstr, len) =+    I.create (fromIntegral len) $ \ptr ->+        I.memcpy ptr (castPtr cstr) (fromIntegral len)++

@@ -1,54 +1,241 @@ -- hexpat, a Haskell wrapper for expat -- Copyright (C) 2008 Evan Martin <martine@danga.com>+-- Copyright (C) 2009 Stephen Blackheath <http://blacksapphire.com/antispam> --- |The Expat.Tree module provides a simplified interface to parsing, that--- returns a tree of the XML structure.  It is written using the lower-level--- bindings in the "Text.XML.Expat.IO" module.  (Note that this is not a lazy--- parse of the document: as soon as the root node is accessed, the entire--- document is parsed.)+-- | 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.+--+-- Extensible \"flavors\" give you the ability to use any string type. Three+-- are provided here: String, ByteString and Text.  module Text.XML.Expat.Tree (-  Text.XML.Expat.Tree.parse, Node(..),-  EIO.Encoding(..)+  -- * Tree structure+  Node(..),+  -- * Parse to tree+  parseTree,+  parseTree',+  Encoding(..),+  XMLParseError(..),+  -- * SAX-style parse+  parseSAX,+  SAXEvent(..),+  -- * Flavors+  TreeFlavor(..),+  stringFlavor,+  byteStringFlavor,+  textFlavor ) where -import qualified Text.XML.Expat.IO as EIO-import qualified Data.ByteString.Lazy as B+import Text.XML.Expat.IO+import qualified Data.ByteString as B+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.Text as T+import qualified Data.Text.Encoding as TE+import qualified Codec.Binary.UTF8.String as U8+import Data.Binary.Put+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 --- |Simplistic XML tree representation.-data Node = Element { eName :: String, eAttrs :: [(String,String)],-                      eChildren :: [Node] }-          | Text String-          deriving Show -modifyChildren :: ([Node] -> [Node]) -> Node -> Node+data TreeFlavor tag text = TreeFlavor+        (CString -> IO tag)+        (CStringLen -> IO text)+        (tag -> Put)+        (text -> B.ByteString)++-- | Flavor for String data type.+stringFlavor :: TreeFlavor String String+stringFlavor = TreeFlavor unpack unpackLen (mapM_ (putWord8 . c2w)) pack+  where+    unpack    cstr = U8.decodeString <$> peekCString cstr+    unpackLen cstr = U8.decodeString <$> peekCStringLen cstr+    pack = B.pack . map c2w . U8.encodeString++-- | Flavor for ByteString data type, containing UTF-8 encoded Unicode.+byteStringFlavor :: TreeFlavor B.ByteString B.ByteString+byteStringFlavor = TreeFlavor unpack unpackLen putByteString id+  where+    unpack    cstr = peekByteString cstr+    unpackLen cstr = peekByteStringLen cstr++-- | Flavor for Text data type.+textFlavor :: TreeFlavor T.Text T.Text+textFlavor = TreeFlavor unpack unpackLen (putByteString . TE.encodeUtf8) TE.encodeUtf8+  where+    unpack    cstr = TE.decodeUtf8 <$> peekByteString cstr+    unpackLen cstr = TE.decodeUtf8 <$> peekByteStringLen cstr++peekByteString :: CString -> IO B.ByteString+{-# INLINE peekByteString #-}+peekByteString cstr = do+    len <- I.c_strlen cstr+    peekByteStringLen (castPtr cstr, fromIntegral len)++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 {+        eName     :: !tag,+        eAttrs    :: ![(tag,text)],+        eChildren :: [Node tag text]+    } |+    Text !text+    deriving (Eq, Show)++instance (NFData tag, NFData text) => NFData (Node tag text) where+    rnf (Element nam att chi) = rnf (nam, att, chi)+    rnf (Text txt) = rnf txt++modifyChildren :: ([Node tag text] -> [Node tag text])+               -> Node tag text+               -> Node tag text modifyChildren f node = node { eChildren = f (eChildren node) } --- |@parse enc doc@ parses /lazy/ bytestring XML content @doc@ with optional--- encoding override @enc@ and returns the root 'Node' of the document if there--- were no parsing errors.-parse :: Maybe EIO.Encoding -> B.ByteString -> Maybe Node-parse enc doc = unsafePerformIO $ runParse where+-- | Strictly parse XML to tree. Returns error message or valid parsed tree.+parseTree' :: TreeFlavor tag text -- ^ Flavor, which determines the string type to use in the output+           -> Maybe Encoding      -- ^ Optional encoding override+           -> B.ByteString        -- ^ Input text (a lazy ByteString)+           -> Either XMLParseError (Node tag text)+{-# SPECIALIZE parseTree' :: TreeFlavor String String -> Maybe Encoding+          -> B.ByteString -> Either XMLParseError (Node String String) #-}+{-# SPECIALIZE parseTree' :: TreeFlavor B.ByteString B.ByteString -> Maybe Encoding+          -> B.ByteString -> Either XMLParseError (Node B.ByteString B.ByteString) #-}+{-# SPECIALIZE parseTree' :: TreeFlavor T.Text T.Text -> Maybe Encoding+          -> B.ByteString -> Either XMLParseError (Node T.Text T.Text) #-}+parseTree' (TreeFlavor mkTag mkText _ _) enc doc = unsafePerformIO $ runParse where   runParse = do-    parser <- EIO.newParser enc+    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.-    stack <- newIORef [Element "" [] []]-    EIO.setStartElementHandler  parser (\n a -> modifyIORef stack (start n a))-    EIO.setEndElementHandler    parser (\n -> modifyIORef stack (end n))-    EIO.setCharacterDataHandler parser (\s -> modifyIORef stack (text s))-    ok <- EIO.parse parser doc-    if ok-      then do-        [Element _ _ [root]] <- readIORef stack-        return $ Just root-      else return Nothing+    emptyString <- withCString "" mkTag +    stack <- newIORef [Element emptyString [] []]+    setStartElementHandler parser $ \cName cAttrs -> do+        name <- mkTag cName+        attrs <- forM cAttrs $ \(cAttrName,cAttrValue) -> do+            attrName <- mkTag cAttrName+            len <- c_strlen cAttrValue+            attrValue <- mkText (cAttrValue, fromIntegral len)+            return (attrName, attrValue)+        modifyIORef stack (start name attrs)+        return True+    setEndElementHandler parser $ \cName -> do+        name <- mkTag cName+        modifyIORef stack (end name)+        return True+    setCharacterDataHandler parser $ \cText -> do+        txt <- mkText cText+        modifyIORef stack (text txt)+        return True+    mError <- parse parser doc+    case mError of+        Just error -> return $ Left error+        Nothing -> do+            [Element _ _ [root]] <- readIORef stack+            return $ Right root+               start name attrs stack = Element name attrs [] : stack   text str (cur:rest) = modifyChildren (Text str:) cur : rest   end name (cur:parent:rest) =-    if eName cur /= name then error "name mismatch" else     let node = modifyChildren reverse cur in     modifyChildren (node:) parent : rest++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++-- | Lazily parse XML to SAX events. In the event of an error, FailDocument is+-- the last element of the output list.+parseSAX :: TreeFlavor tag text -- ^ Flavor, which determines the string type to use in the output+         -> Maybe Encoding      -- ^ Optional encoding override+         -> L.ByteString        -- ^ Input text (a lazy ByteString)+         -> [SAXEvent tag text]+parseSAX (TreeFlavor mkTag mkText _ _) enc input = unsafePerformIO $ do+    parser <- newParser enc+    queueRef <- newIORef []+    setStartElementHandler parser $ \cName cAttrs -> do+        name <- mkTag cName+        attrs <- forM cAttrs $ \(cAttrName,cAttrValue) -> do+            attrName <- mkTag cAttrName+            len <- c_strlen cAttrValue+            attrValue <- mkText (cAttrValue, fromIntegral len)+            return (attrName, attrValue)+        modifyIORef queueRef (StartElement name attrs:)+        return True+    setEndElementHandler parser $ \cName -> do+        name <- mkTag cName+        modifyIORef queueRef (EndElement name:)+        return True+    setCharacterDataHandler parser $ \cText -> do+        txt <- mkText cText+        modifyIORef queueRef (CharacterData txt:)+        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 -> return [FailDocument error]+                Nothing -> runParser cs+            return $ reverse queue ++ rem++    runParser $ L.toChunks input++-- | 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 :: TreeFlavor tag text -- ^ Flavor, which determines the string type to use in the tree+          -> Maybe Encoding      -- ^ Optional encoding override+          -> L.ByteString        -- ^ Input text (a lazy ByteString)+          -> (Node tag text, Maybe XMLParseError)+{-# SPECIALIZE parseTree :: TreeFlavor String String -> Maybe Encoding+          -> L.ByteString -> (Node String String, Maybe XMLParseError) #-}+{-# SPECIALIZE parseTree :: TreeFlavor B.ByteString B.ByteString -> Maybe Encoding+          -> L.ByteString -> (Node B.ByteString B.ByteString, Maybe XMLParseError) #-}+{-# SPECIALIZE parseTree :: TreeFlavor T.Text T.Text -> Maybe Encoding+          -> L.ByteString -> (Node T.Text T.Text, Maybe XMLParseError) #-}+parseTree flavor@(TreeFlavor mkTag _ _ _) mEnc bs =+    let events = parseSAX flavor mEnc bs+        (nodes, mError, _) = ptl events+    in  (safeHead nodes, mError)+  where+    safeHead (a:_) = a+    safeHead [] = Element (unsafePerformIO $ withCString "" mkTag) [] []+    ptl (StartElement name attrs:rem) =+        let (children, err1, rem') = ptl rem+            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')+    ptl (FailDocument err:_) = ([], Just err, [])+    ptl [] = ([], Nothing, []) 

@@ -1,33 +1,63 @@ Cabal-Version: >= 1.2 Name: hexpat-Version: 0.3+Version: 0.4 Synopsis: wrapper for expat, the fast XML parser Description:   Expat (<http://expat.sourceforge.net/>) is a stream-oriented XML parser-  written in C.  It is known for being simple and fast.+  written in C.   .-  There are already nice XML libraries in the Text.XML hierarchy.  The-  reason to use Expat is when speed is of concern.  From a benchmark-  that compares getting the length of the root node of a HaXml tree-  (presumably forcing parsing the entire file) against running an Expat-  parser with a registered start node handler, Expat is about 12 times-  faster.  This is not a fair benchmark; HaXml does a lot more than this-  Expat library.  But if Expat suffices, it is good for what it does.+  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.+  .+  The emphasis is on speed and simplicity. If you want more complete and powerful+  XML libraries, consider using HaXml or HXT instead.+  .+  Note that hexpat has undergone a major API change since 0.3.x.+  .+  Benchmark results on ghc 6.10.1 against HaXml for parsing a 4K xml file with non-threading runtime:+  HAXML: 2683 us, HEXPAT: low-level parse-no tree: 243 us, lazy-String: 1340 us,+  lazy-Text: 814 us, strict-String: 1194 us, strict-Text: 732 us+  .+  With -threaded:+  HAXML: 2691 us, HEXPAT: low-level parse-no tree: 472 us,+  lazy-String: 1575 us, lazy-Text: 1068 us, strict-String: 1396 us,+  strict-Text: 964 us Category: XML License: BSD3 License-File: LICENSE-Author: Evan Martin, Stephen Blackheath+Author: Stephen Blackheath (blackh), Evan Martin, Matthew Pocock (drdozer) Maintainer: http://blacksapphire.com/antispam/-Copyright: (c) 2008 Evan Martin <martine@danga.com>, (c) 2008 Stephen Blackheath+Copyright:+  (c) 2009 Stephen Blackheath <http://blacksapphire.com/antispam/>,+  (c) 2008 Evan Martin <martine@danga.com>,+  (c) 2009 Matthew Pocock <matthew.pocock@ncl.ac.uk> Homepage: http://code.haskell.org/hexpat/-Extra-Source-Files: test.hs, perf.hs, test2.hs+Extra-Source-Files:+  test/tests.hs,+  test/perf.hs,+  test/test.xml,+  test/benchmark.hs,+  test/lazySAX.hs,+  test/lazyTree.hs Build-Type: Simple Stability: beta  Library-  Build-Depends: base, haskell98, bytestring-  Exposed-Modules: Text.XML.Expat.IO, Text.XML.Expat.Tree, Text.XML.Expat.Format-  Other-Modules: C2HS+  Build-Depends:+    base,+    haskell98,+    bytestring,+    mtl >= 1.1.0.0,+    text >= 0.1,+    binary >= 0.4,+    utf8-string >= 0.3.3,+    parallel+  Exposed-Modules:+    Text.XML.Expat.Tree,+    Text.XML.Expat.Format,+    Text.XML.Expat.Qualified,+    Text.XML.Expat.IO   Extensions: ForeignFunctionInterface   Extra-Libraries: expat 

@@ -1,42 +0,0 @@--- hexpat, a Haskell wrapper for expat--- Copyright (C) 2008 Evan Martin <martine@danga.com>---- This program microbenchmarks HaXml versus Expat parsing.--- The comparision is pretty unfair; HaXml does a whole lot more.--- However, if you just want to read all the XML tags in a file,--- this program demonstrates why Expat may be preferable.--import Control.Exception-import qualified Data.ByteString.Lazy as BS-import Data.Char (ord)-import Data.IORef-import Microbench-import Text.XML.Expat.IO as Expat-import Text.XML.HaXml as HaXml--parse_haxml :: String -> IO ()-parse_haxml input = do-  let Document _ _ root _ = HaXml.xmlParse "input" input-  let Elem _ _ content = root-  evaluate $ length content-  return ()--parse_expat :: BS.ByteString -> IO ()-parse_expat input = do-  parser <- Expat.newParser Nothing-  counter <- newIORef 0-  Expat.setStartElementHandler parser (elementHandler counter)-  Expat.parse parser input-  readIORef counter-  return ()-  where-  elementHandler counter tag attrs = modifyIORef counter (+1)--main = do-  xml <- readFile "test.xml"-  let xmlbs = BS.pack (map (fromIntegral.ord) xml)-  -- Force reading the entire file first.-  putStrLn $ "input is " ++ show (BS.length xmlbs) ++ " bytes."-  -- Start the races.-  microbench "HaXml" (parse_haxml xml)-  microbench "hexpat" (parse_expat xmlbs)

@@ -1,31 +0,0 @@-import qualified Text.XML.Expat.IO as EIO-import qualified Text.XML.Expat.Tree as ETree-import qualified Data.ByteString.Lazy as B-import Data.Tree-import Data.Char--toByteString :: String -> B.ByteString-toByteString = B.pack . map (fromIntegral . ord)--main_eio doc = do-  parser <- EIO.newParser Nothing-  EIO.setStartElementHandler parser startElement-  EIO.parse parser doc-  putStrLn "ok"-  where-  startElement name attrs = putStrLn $ show name ++ " " ++ show attrs--main_tree doc = do-  let etree = ETree.parse Nothing doc-  --let dtree = toDTree etree-  --putStrLn (drawTree dtree)-  etree `seq` putStrLn "ok"-  where-  toDTree (ETree.Element name attrs kids) =-    Node ("<" ++ name ++ " " ++ show attrs ++ ">") (map toDTree kids)-  toDTree (ETree.Text str) = Node (show str) []--main = do-  let doc = "<foo baz='bah'><bar/><text>some &amp; text</text></foo>"-  xml <- readFile "test.xml"-  main_eio (toByteString xml)

@@ -0,0 +1,79 @@+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 flavor enc xml = parseTree flavor enc (L.fromChunks [xml])++tests :: [(String, B.ByteString -> String -> IO ())]+tests = [+    ("HaXml", \_ xml -> rnf (HaXml.xmlParse "input" xml) `seq` return ()),+    ("low-level parse only, no tree", parseOnly),+    ("lazy myParseTree stringFlavor", \xml _ -> rnf (myParseTree stringFlavor Nothing xml) `seq` return ()),+    ("lazy myParseTree byteStringFlavor", \xml _ -> rnf (myParseTree byteStringFlavor Nothing xml) `seq` return ()),+    ("lazy myParseTree textFlavor", \xml _ -> rnf (myParseTree textFlavor Nothing xml) `seq` return ()),+    ("lazy myParseTree qualifiedStringFlavor", \xml _ -> rnf (myParseTree qualifiedStringFlavor Nothing xml) `seq` return ()),+    ("lazy myParseTree qualifiedByteStringFlavor", \xml _ -> rnf (myParseTree qualifiedByteStringFlavor Nothing xml) `seq` return ()),+    ("lazy myParseTree qualifiedTextFlavor", \xml _ -> rnf (myParseTree qualifiedTextFlavor Nothing xml) `seq` return ()),+    ("strict parseTree' stringFlavor", \xml _ -> rnf (parseTree' stringFlavor Nothing xml) `seq` return ()),+    ("strict parseTree' byteStringFlavor", \xml _ -> rnf (parseTree' byteStringFlavor Nothing xml) `seq` return ()),+    ("strict parseTree' textFlavor", \xml _ -> rnf (parseTree' textFlavor Nothing xml) `seq` return ()),+    ("strict parseTree' qualifiedStringFlavor", \xml _ -> rnf (parseTree' qualifiedStringFlavor Nothing xml) `seq` return ()),+    ("strict parseTree' qualifiedByteStringFlavor", \xml _ -> rnf (parseTree' qualifiedByteStringFlavor Nothing xml) `seq` return ()),+    ("strict parseTree' qualifiedTextFlavor", \xml _ -> rnf (parseTree' qualifiedTextFlavor Nothing xml) `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+

@@ -0,0 +1,25 @@+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 byteStringFlavor Nothing infiniteBL+

@@ -0,0 +1,25 @@+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 stringFlavor Nothing infiniteBL+

@@ -0,0 +1,42 @@+-- hexpat, a Haskell wrapper for expat+-- Copyright (C) 2008 Evan Martin <martine@danga.com>++-- This program microbenchmarks HaXml versus Expat parsing.+-- The comparision is pretty unfair; HaXml does a whole lot more.+-- However, if you just want to read all the XML tags in a file,+-- this program demonstrates why Expat may be preferable.++import Control.Exception+import qualified Data.ByteString.Lazy as BS+import Data.Char (ord)+import Data.IORef+import Microbench+import Text.XML.Expat.IO as Expat+import Text.XML.HaXml as HaXml++parse_haxml :: String -> IO ()+parse_haxml input = do+  let Document _ _ root _ = HaXml.xmlParse "input" input+  let Elem _ _ content = root+  evaluate $ length content+  return ()++parse_expat :: BS.ByteString -> IO ()+parse_expat input = do+  parser <- Expat.newParser Nothing+  counter <- newIORef 0+  Expat.setStartElementHandler parser (elementHandler counter)+  Expat.parse parser input+  readIORef counter+  return ()+  where+  elementHandler counter tag attrs = modifyIORef counter (+1)++main = do+  xml <- readFile "test.xml"+  let xmlbs = BS.pack (map (fromIntegral.ord) xml)+  -- Force reading the entire file first.+  putStrLn $ "input is " ++ show (BS.length xmlbs) ++ " bytes."+  -- Start the races.+  microbench "HaXml" (parse_haxml xml)+  microbench "hexpat" (parse_expat xmlbs)

@@ -0,0 +1,101 @@+<?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>

@@ -0,0 +1,119 @@+import Text.XML.Expat.Tree+import Text.XML.Expat.Format+import Text.XML.Expat.Qualified+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL+import Data.ByteString.Internal (c2w, w2c)+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++toByteStringL :: String -> BSL.ByteString+toByteStringL = BSL.pack . map c2w++fromByteStringL :: BSL.ByteString -> String+fromByteStringL = map w2c . BSL.unpack++toByteString :: String -> BS.ByteString+toByteString = BS.pack . map c2w++fromByteString :: BS.ByteString -> String+fromByteString = map w2c . BS.unpack++testDoc :: (Show tag, Show text) =>+           (Maybe Encoding -> bs -> Either XMLParseError (Node tag text))+        -> (Node tag text -> BSL.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' stringFlavor Nothing (toByteString "<hello></goodbye>")+    assertEqual "error1" (Left $ XMLParseError "mismatched tag" 1 9) eDoc++test_error2 :: IO ()+test_error2 = do+    assertEqual "error2" (+            Element {eName = "hello", eAttrs = [], eChildren = []},+            Just (XMLParseError "mismatched tag" 1 9)+        ) $ parseTree stringFlavor Nothing+              (toByteStringL "<hello></goodbye>")++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" 1 35)+        ) $ parseTree stringFlavor Nothing+              (toByteStringL "<open><test1>Hello</test1><hello></goodbye>")++test_error4 :: IO ()+test_error4 = do+    let eDoc = parseTree' stringFlavor Nothing (toByteString "!")+    assertEqual "error1" (Left $ XMLParseError "not well-formed (invalid token)" 1 0) eDoc++main = do+    testXML <- 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' stringFlavor, formatTree stringFlavor),+        TestCase $ t' ("ByteString", parseTree' byteStringFlavor, formatTree byteStringFlavor),+        TestCase $ t' ("Text", parseTree' textFlavor, formatTree textFlavor),+        TestCase $ t ("String/Lazy", eitherify $ parseTree stringFlavor, formatTree stringFlavor),+        TestCase $ t ("ByteString/Lazy", eitherify $ parseTree byteStringFlavor, formatTree byteStringFlavor),+        TestCase $ t ("Text/Lazy", eitherify $ parseTree textFlavor, formatTree textFlavor),+        TestCase $ t' ("String/Qualified", parseTree' qualifiedStringFlavor, formatTree qualifiedStringFlavor),+        TestCase $ t' ("ByteString/Qualified", parseTree' qualifiedByteStringFlavor, formatTree qualifiedByteStringFlavor),+        TestCase $ t' ("Text/Qualified", parseTree' qualifiedTextFlavor, formatTree qualifiedTextFlavor),+        TestCase $ t ("String/Qualified/Lazy", eitherify $ parseTree qualifiedStringFlavor, formatTree qualifiedStringFlavor),+        TestCase $ t ("ByteString/Qualified/Lazy", eitherify $ parseTree qualifiedByteStringFlavor, formatTree qualifiedByteStringFlavor),+        TestCase $ t ("Text/Qualified/Lazy", eitherify $ parseTree qualifiedTextFlavor, formatTree qualifiedTextFlavor),+        TestCase $ test_error1,+        TestCase $ test_error2,+        TestCase $ test_error3,+        TestCase $ test_error4+      ]+

@@ -1,29 +0,0 @@-import Text.XML.Expat.IO-import Text.XML.Expat.Tree as T-import Text.XML.Expat.Format-import qualified Data.ByteString.Lazy as B-import Data.Char-import Data.Maybe--toByteString :: String -> B.ByteString-toByteString = B.pack . map (fromIntegral . ord)--test :: String -> IO ()-test xml = do-  let mTree = T.parse (Just UTF8) (toByteString xml)-  --putStrLn $ show mTree-  case mTree of-      Just tree -> do-          let out = formatDoc (Just UTF8) tree-          if out == xml-              then putStrLn "passed"-              else do-                  putStrLn $ "FAILED: mismatch"-                  putStrLn $ "input="++xml-                  putStrLn $ "output="++out-      Nothing ->-          putStrLn "FAILED: parse failed"--main = do-  test "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n<test><test1 type=\"expression\">Cat &amp; mouse</test1><test2 type=\"communication\">Dog &amp; bone</test2></test>"-  test "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n<test>Cat &amp; mouse</test>"