diff --git a/Text/XML/Expat/IO.hs b/Text/XML/Expat/IO.hs --- a/Text/XML/Expat/IO.hs +++ b/Text/XML/Expat/IO.hs @@ -10,14 +10,14 @@ -- -- (2) Set up callbacks on the parser: 'setStartElementHandler', etc. -- --- (3) Feed data into the parser: 'parse' or 'parseChunk'. +-- (3) Feed data into the parser: 'parse', 'parse'' or 'parseChunk'. module Text.XML.Expat.IO ( -- ** Parser Setup Parser, newParser, -- ** Parsing - parse, parseChunk, Encoding(..), XMLParseError(..), + parse, parse', parseChunk, Encoding(..), XMLParseError(..), getParseLocation, XMLParseLocation(..), @@ -52,8 +52,8 @@ type ParserPtr = Ptr () data Parser = Parser (ForeignPtr ()) - (IORef CStartElementHandler) - (IORef CEndElementHandler) + (IORef CStartElementHandler) + (IORef CEndElementHandler) (IORef CCharacterDataHandler) instance Show Parser where @@ -76,7 +76,7 @@ parserCreate :: Maybe Encoding -> IO (ParserPtr) parserCreate a1 = - withOptEncoding a1 $ \a1' -> + withOptEncoding a1 $ \a1' -> parserCreate'_ a1' >>= \res -> let {res' = id res} in return (res') @@ -103,10 +103,26 @@ unStatus 0 = False unStatus 1 = True --- |@parse data@ feeds /lazy/ bytestring data into a parser. It returns Nothing +-- |@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 -> BSL.ByteString -> IO (Maybe XMLParseError) parse parser@(Parser _ _ _ _) bs = withHandlers parser $ do + ok <- doParseChunks (BSL.toChunks bs) + if ok + then return Nothing + else Just `fmap` getError parser + where + doParseChunks [] = doParseChunk parser BS.empty True + doParseChunks (c:cs) = do + ok <- doParseChunk parser c False + if ok + 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' :: Parser -> BS.ByteString -> IO (Maybe XMLParseError) +parse' parser@(Parser _ _ _ _) bs = withHandlers parser $ do ok <- doParseChunk parser bs True if ok then return Nothing @@ -117,7 +133,7 @@ -- final parameter. It returns Nothing on success, or Just the parse error. parseChunk :: Parser -> BS.ByteString - -> Bool + -> Bool -- ^ True if last chunk -> IO (Maybe XMLParseError) parseChunk parser xml final = withHandlers parser $ unsafeParseChunk parser xml final @@ -181,9 +197,9 @@ 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 + 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') @@ -253,7 +269,7 @@ -- 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 +-- 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. @@ -283,7 +299,7 @@ cattrlist <- peekArray0 nullPtr cattrs stillRunning <- handler cname (pairwise cattrlist) unless stillRunning $ - withParser parser $ \p -> xmlStopParser p 0 + withParser parser $ \p -> xmlStopParser p 0 -- |Attach a StartElementHandler to a Parser. setStartElementHandler :: Parser -> StartElementHandler -> IO () @@ -303,7 +319,7 @@ h ptr cname = do stillRunning <- handler cname unless stillRunning $ - withParser parser $ \p -> xmlStopParser p 0 + withParser parser $ \p -> xmlStopParser p 0 -- |Attach an EndElementHandler to a Parser. setEndElementHandler :: Parser -> EndElementHandler -> IO () @@ -323,7 +339,7 @@ h ptr cdata len = do stillRunning <- handler (cdata, fromIntegral len) unless stillRunning $ - withParser parser $ \p -> xmlStopParser p 0 + withParser parser $ \p -> xmlStopParser p 0 -- | Attach an CharacterDataHandler to a Parser. setCharacterDataHandler :: Parser -> CharacterDataHandler -> IO () diff --git a/Text/XML/Expat/Namespaced.hs b/Text/XML/Expat/Namespaced.hs --- a/Text/XML/Expat/Namespaced.hs +++ b/Text/XML/Expat/Namespaced.hs @@ -41,7 +41,7 @@ -- | Type shortcut for a single node where namespaced names are used for tags type NNode text = Node (NName text) text --- | Type shortcut for attributes where namespaced names are used for tags +-- | Type shortcut for attributes with namespaced names type NAttributes text = Attributes (NName text) text -- | Make a new NName from a prefix and localPart. diff --git a/Text/XML/Expat/Qualified.hs b/Text/XML/Expat/Qualified.hs --- a/Text/XML/Expat/Qualified.hs +++ b/Text/XML/Expat/Qualified.hs @@ -60,7 +60,7 @@ -- | Type shortcut for a single node where qualified names are used for tags type QNode text = Node (QName text) text --- | Type shortcut for attributes where qualified names are used for tags +-- | Type shortcut for attributes with qualified names type QAttributes text = Attributes (QName text) text -- | Make a new QName from a prefix and localPart. diff --git a/Text/XML/Expat/Tree.hs b/Text/XML/Expat/Tree.hs --- a/Text/XML/Expat/Tree.hs +++ b/Text/XML/Expat/Tree.hs @@ -14,14 +14,14 @@ -- -- > -- | 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 @@ -29,7 +29,7 @@ -- > otherwise -> do -- > hPutStrLn stderr "Usage: helloworld " -- > exitWith $ ExitFailure 1 --- > +-- > -- > process :: String -> IO () -- > process filename = do -- > inputText <- L.readFile filename @@ -54,7 +54,7 @@ -- > 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 $ "") @@ -70,7 +70,7 @@ -- -- > ... -- > import Control.Exception.Extensible as E --- > +-- > -- > -- This is not the recommended way to handle errors. -- > main = do -- > do @@ -183,7 +183,7 @@ gxFromCStringLen cstr = TE.decodeUtf8 <$> peekByteStringLen cstr gxToByteString = TE.encodeUtf8 -peekByteStringLen :: CStringLen -> IO B.ByteString +peekByteStringLen :: CStringLen -> IO B.ByteString {-# INLINE peekByteStringLen #-} peekByteStringLen (cstr, len) = I.create (fromIntegral len) $ \ptr -> @@ -218,7 +218,7 @@ -- text are the same string type. type UNode text = Node text text --- | Type shortcut for attributes with unqualified tag names where tag and +-- | Type shortcut for attributes with unqualified names where tag and -- text are the same string type. type UAttributes text = Attributes text text @@ -260,13 +260,13 @@ txt <- gxFromCStringLen cText modifyIORef stack (text txt) return True - mError <- parse parser doc + 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 (cur:parent:rest) = @@ -279,7 +279,7 @@ 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 @@ -288,7 +288,7 @@ -- | 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) => +parseSAX :: (Show tag, Show text, GenericXMLString tag, GenericXMLString text) => Maybe Encoding -- ^ Optional encoding override -> L.ByteString -- ^ Input text (a lazy ByteString) -> [SAXEvent tag text] @@ -312,14 +312,20 @@ modifyIORef queueRef (CharacterData txt:) return True - let runParser [] = return [] - runParser (c:cs) = unsafeInterleaveIO $ do - mError <- parseChunk parser c (null cs) + 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 [] - rem <- case mError of - Just error -> return [FailDocument error] - Nothing -> runParser cs return $ reverse queue ++ rem runParser $ L.toChunks input @@ -331,7 +337,7 @@ instance Exception XMLParseException where -- | Lazily parse XML to SAX events. In the event of an error, throw 'XMLParseException'. -parseSAXThrowing :: (GenericXMLString tag, GenericXMLString text) => +parseSAXThrowing :: (Show tag, Show text, GenericXMLString tag, GenericXMLString text) => Maybe Encoding -- ^ Optional encoding override -> L.ByteString -- ^ Input text (a lazy ByteString) -> [SAXEvent tag text] @@ -408,14 +414,14 @@ -- | 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) => +parseTree :: (Show tag, Show text, 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 -- | Lazily parse XML to tree. In the event of an error, throw 'XMLParseException'. -parseTreeThrowing :: (GenericXMLString tag, GenericXMLString text) => +parseTreeThrowing :: (Show tag, Show text, GenericXMLString tag, GenericXMLString text) => Maybe Encoding -- ^ Optional encoding override -> L.ByteString -- ^ Input text (a lazy ByteString) -> Node tag text diff --git a/hexpat.cabal b/hexpat.cabal --- a/hexpat.cabal +++ b/hexpat.cabal @@ -1,6 +1,6 @@ Cabal-Version: >= 1.2 Name: hexpat -Version: 0.6 +Version: 0.7 Synopsis: wrapper for expat, the fast XML parser Description: Expat () is a stream-oriented XML parser diff --git a/test/benchmark.hs b/test/benchmark.hs --- a/test/benchmark.hs +++ b/test/benchmark.hs @@ -43,7 +43,7 @@ parseOnly :: B.ByteString -> String -> IO () parseOnly xml _ = do parser <- newParser Nothing - parse parser xml + parse' parser xml return () myParseTree enc xml = parseTree enc (L.fromChunks [xml]) diff --git a/test/tests.hs b/test/tests.hs --- a/test/tests.hs +++ b/test/tests.hs @@ -1,12 +1,16 @@ 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 @@ -89,6 +93,29 @@ 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 "Hello"] + 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 + main = do testXML <- readFile "test.xml" -- Remove trailing newline @@ -122,6 +149,7 @@ TestCase $ test_error1, TestCase $ test_error2, TestCase $ test_error3, - TestCase $ test_error4 + TestCase $ test_error4, + TestCase $ test_parse ]