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 @@ -18,6 +18,8 @@ -- ** Parsing parse, parseChunk, Encoding(..), XMLParseError(..), + getParseLocation, + XMLParseLocation(..), -- ** Parser Callbacks StartElementHandler, EndElementHandler, CharacterDataHandler, @@ -41,6 +43,7 @@ import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Internal as BSI import Data.IORef +import Data.Int import Foreign import CForeign @@ -132,13 +135,11 @@ 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) + code <- xmlGetErrorCode p + cerr <- xmlErrorString code + err <- peekCString cerr + loc <- getParseLocation parser + return $ XMLParseError err loc data ExpatHandlers = ExpatHandlers (FunPtr CStartElementHandler) @@ -187,12 +188,36 @@ 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) +-- | Parse error, consisting of message text and error location +data XMLParseError = XMLParseError String XMLParseLocation deriving (Eq, Show) instance NFData XMLParseError where - rnf (XMLParseError msg lin col) = rnf (msg, lin, col) + rnf (XMLParseError msg loc) = rnf (msg, loc) +-- | Specifies a location of an event within the input text +data XMLParseLocation = XMLParseLocation { + xmlLineNumber :: Int64, -- ^ Line number of the event + xmlColumnNumber :: Int64, -- ^ Column number of the event + xmlByteIndex :: Int64, -- ^ Byte index of event from start of document + xmlByteCount :: Int64 -- ^ The number of bytes in the event + } + deriving (Eq, Show) + +instance NFData XMLParseLocation where + rnf (XMLParseLocation lin col ind cou) = rnf (lin, col, ind, cou) + +getParseLocation parser = withParser parser $ \p -> do + line <- xmlGetCurrentLineNumber p + col <- xmlGetCurrentColumnNumber p + index <- xmlGetCurrentByteIndex p + count <- xmlGetCurrentByteCount p + return $ XMLParseLocation { + xmlLineNumber = fromIntegral line, + xmlColumnNumber = fromIntegral col, + xmlByteIndex = fromIntegral index, + 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. @@ -210,12 +235,38 @@ type CStartElementHandler = Ptr () -> CString -> Ptr CString -> IO () nullCStartElementHandler _ _ _ = return () +-- 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 CUInt -- to do: Get 64-bit value if supported (how?) + :: ParserPtr -> IO CULong foreign import ccall unsafe "expat.h XML_GetCurrentColumnNumber" xmlGetCurrentColumnNumber - :: ParserPtr -> IO CUInt -- to do: Get 64-bit value if supported (how?) + :: 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 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 @@ -94,17 +94,22 @@ (nsAtts, otherAtts) = L.partition ((== Just xmlns) . qnPrefix . fst) qattrs (dfAtt, normalAtts) = L.partition ((== QName Nothing xmlns) . fst) otherAtts nsMap = M.fromList $ for nsAtts $ \((QName _ lp), uri) -> (Just lp, Just uri) + -- fixme: when snd q is null, use Nothing dfMap = M.fromList $ for dfAtt $ \q -> (Nothing, Just $ snd q) chldBs = M.unions [dfMap, nsMap, bindings] - trans (QName pref qual) = case pref `M.lookup` chldBs of + + trans bs (QName pref qual) = case pref `M.lookup` bs of Nothing -> error $ "Namespace prefix referenced but never bound: '" ++ (show . DM.fromJust) pref ++ "'" Just mUri -> NName mUri qual - transAt (qn, v) = (trans qn, v) + nname = trans chldBs qname - nname = trans qname + -- attributes with no prefix are in the same namespace as the element + attBs = M.insert Nothing (nnNamespace nname) chldBs + + transAt (qn, v) = (trans attBs qn, v) nNsAtts = map transAt nsAtts nDfAtt = map transAt dfAtt 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 @@ -10,16 +10,50 @@ -- 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: +-- +-- > -- | 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 " +-- > 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 +-- -- Error handling in strict parses is very straight forward - just check the -- 'Either' return value. Lazy parses are not so simple. Here are two working -- examples that illustrate the ways to handle errors. Here they are: -- --- Way no. 1 +-- Way no. 1 - Using a Maybe value -- -- > 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 the recommended way to handle errors in lazy parses -- > main = do @@ -30,8 +64,10 @@ -- > Just err -> putStrLn $ "It failed : "++show err -- > Nothing -> putStrLn "Success!" -- --- Way no. 2 +-- Way no. 2 - Using exceptions -- +-- Unless exceptions fit in with the design of your program, this way is less preferred. +-- -- > ... -- > import Control.Exception.Extensible as E -- > @@ -60,10 +96,12 @@ parseTree', Encoding(..), XMLParseError(..), + XMLParseLocation(..), -- * SAX-style parse parseSAX, SAXEvent(..), saxToTree, + parseSAXLocations, -- * Variants that throw exceptions XMLParseException(..), parseSAXThrowing, @@ -301,6 +339,49 @@ where freakOut (FailDocument err) = Exc.throw $ XMLParseException err freakOut other = other + +-- | 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 -- | A lower level function that lazily converts a SAX stream into a tree structure. saxToTree :: GenericXMLString tag => 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.5 +Version: 0.6 Synopsis: wrapper for expat, the fast XML parser Description: Expat () is a stream-oriented XML parser @@ -13,16 +13,9 @@ 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: 2631 us, HEXPAT: low-level parse-no tree: 243 us, lazy-String: 1240 us, - lazy-Text: 782 us, strict-String: 1125 us, strict-Text: 770 us + Examples and benchmarks: . - With -threaded: - HAXML: 2667 us, HEXPAT: low-level parse-no tree: 472 us, - lazy-String: 1453 us, lazy-Text: 1057 us, strict-String: 1342 us, - strict-Text: 943 us + DARCS repository: Category: XML License: BSD3 License-File: LICENSE @@ -32,7 +25,7 @@ (c) 2009 Stephen Blackheath , (c) 2008 Evan Martin , (c) 2009 Matthew Pocock -Homepage: http://code.haskell.org/hexpat/ +Homepage: http://haskell.org/haskellwiki/Hexpat/ Extra-Source-Files: test/tests.hs, test/test.xml, @@ -40,8 +33,12 @@ test/lazySAX.hs, test/lazyTree.hs, test/lazyTreeThrow.hs, + test/leak.hs, test/errorHandlingWay1.hs, - test/errorHandlingWay2.hs + test/errorHandlingWay2.hs, + test/helloworld.hs, + test/locations.hs, + test/Makefile Build-Type: Simple Stability: beta diff --git a/test/Makefile b/test/Makefile new file mode 100644 --- /dev/null +++ b/test/Makefile @@ -0,0 +1,28 @@ +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 diff --git a/test/helloworld.hs b/test/helloworld.hs new file mode 100644 --- /dev/null +++ b/test/helloworld.hs @@ -0,0 +1,33 @@ +-- | 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 " + 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 + diff --git a/test/leak.hs b/test/leak.hs new file mode 100644 --- /dev/null +++ b/test/leak.hs @@ -0,0 +1,63 @@ +-- 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 = ""++body 1 + where + body 10000 = "" + body i = "\n "++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" + diff --git a/test/locations.hs b/test/locations.hs new file mode 100644 --- /dev/null +++ b/test/locations.hs @@ -0,0 +1,25 @@ +-- | 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 " + 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 + diff --git a/test/tests.hs b/test/tests.hs --- a/test/tests.hs +++ b/test/tests.hs @@ -62,13 +62,13 @@ test_error1 :: IO () test_error1 = do let eDoc = parseTree' Nothing (toByteString "") :: Either XMLParseError (UNode String) - assertEqual "error1" (Left $ XMLParseError "mismatched tag" 1 9) eDoc + 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" 1 9) + Just (XMLParseError "mismatched tag" (XMLParseLocation 1 9 9 0)) ) (parseTree Nothing (toByteStringL "") :: (UNode String, Maybe XMLParseError)) @@ -79,14 +79,15 @@ Element {eName = "test1", eAttrs = [], eChildren = [Text "Hello"]}, Element {eName = "hello", eAttrs = [], eChildren = []} ]}, - Just (XMLParseError "mismatched tag" 1 35) + Just (XMLParseError "mismatched tag" (XMLParseLocation 1 35 35 0)) ) $ parseTree Nothing (toByteStringL "Hello") test_error4 :: IO () test_error4 = do let eDoc = parseTree' Nothing (toByteString "!") :: Either XMLParseError (UNode String) - assertEqual "error1" (Left $ XMLParseError "not well-formed (invalid token)" 1 0) eDoc + assertEqual "error1" (Left $ XMLParseError "not well-formed (invalid token)" + (XMLParseLocation 1 0 0 0)) eDoc main = do testXML <- readFile "test.xml"