diff --git a/Text/XML/Expat/SAX.hs b/Text/XML/Expat/SAX.hs --- a/Text/XML/Expat/SAX.hs +++ b/Text/XML/Expat/SAX.hs @@ -32,6 +32,9 @@ parseSAXLocationsThrowing, parseSAXThrowing, + -- * Helpers + setEntityDecoder, + -- * Abstraction of string types GenericXMLString(..) ) where @@ -145,66 +148,36 @@ len <- c_strlen cstr gxFromCStringLen (cstr, fromIntegral len) - +-- | A helper for configuring the hexpat parser to use the specified entity +-- decoder. setEntityDecoder :: (GenericXMLString tag, GenericXMLString text) => Parser - -> IORef [SAXEvent tag text] - -> (tag -> Maybe text) + -> (tag -> Maybe text) -- ^ Entity decoder + -> (ParserPtr -> text -> IO ()) -- ^ Code to insert character data into the document -> IO () -setEntityDecoder parser queueRef decoder = do - setUseForeignDTD parser True - setExternalEntityRefHandler parser eh - setSkippedEntityHandler parser skip - - where - skip _ _ 1 = return False - skip _ entityName 0 = do - en <- textFromCString entityName - let mbt = decoder en - maybe (return False) - (\t -> do - modifyIORef queueRef (CharacterData t:) - return True) - mbt - skip _ _ _ = undefined - - eh p ctx _ systemID publicID = - if systemID == nullPtr && publicID == nullPtr - then withCStringLen "" $ \c -> do - parseExternalEntityReference p ctx Nothing c - else return False - - -setEntityDecoderLoc :: (GenericXMLString tag, GenericXMLString text) - => Parser - -> IORef [(SAXEvent tag text, XMLParseLocation)] - -> (tag -> Maybe text) - -> IO () -setEntityDecoderLoc parser queueRef decoder = do +setEntityDecoder parser decoder insertText = do setUseForeignDTD parser True setExternalEntityRefHandler parser eh setSkippedEntityHandler parser skip where - skip _ _ 1 = return False + skip _ _ 1 = return False skip pp entityName 0 = do en <- textFromCString entityName let mbt = decoder en maybe (return False) (\t -> do - loc <- getParseLocation pp - modifyIORef queueRef ((CharacterData t,loc):) + insertText pp t return True) mbt skip _ _ _ = undefined - eh p ctx _ systemID publicID = + eh pp ctx _ systemID publicID = if systemID == nullPtr && publicID == nullPtr then withCStringLen "" $ \c -> do - parseExternalEntityReference p ctx Nothing c + parseExternalEntityReference pp ctx Nothing c else return False - -- | Lazily parse XML to SAX events. In the event of an error, FailDocument is -- the last element of the output list. parse :: (GenericXMLString tag, GenericXMLString text) => @@ -218,9 +191,10 @@ parser <- newParser enc queueRef <- newIORef [] - maybe (return ()) - (setEntityDecoder parser queueRef) - mEntityDecoder + case mEntityDecoder of + Just deco -> setEntityDecoder parser deco $ \_ txt -> do + modifyIORef queueRef (CharacterData txt:) + Nothing -> return () setStartElementHandler parser $ \_ cName cAttrs -> do name <- textFromCString cName @@ -293,9 +267,11 @@ parser <- newParser enc queueRef <- newIORef [] - maybe (return ()) - (setEntityDecoderLoc parser queueRef) - mEntityDecoder + case mEntityDecoder of + Just deco -> setEntityDecoder parser deco $ \pp txt -> do + loc <- getParseLocation pp + modifyIORef queueRef ((CharacterData txt, loc):) + Nothing -> return () setStartElementHandler parser $ \pp cName cAttrs -> do name <- textFromCString cName @@ -319,17 +295,24 @@ modifyIORef queueRef ((CharacterData txt, loc):) return True - let runParser [] = return [] - runParser (c:cs) = unsafeInterleaveIO $ do + let runParser inp = unsafeInterleaveIO $ do + rema <- withParser parser $ \pp -> case inp of + (c:cs) -> do + mError <- parseChunk pp c False + case mError of + Just err -> do + loc <- getParseLocation pp + return [(FailDocument err, loc)] + Nothing -> runParser cs + [] -> do + mError <- parseChunk pp B.empty True + case mError of + Just err -> do + loc <- getParseLocation pp + return [(FailDocument err, loc)] + Nothing -> return [] queue <- readIORef queueRef writeIORef queueRef [] - rema <- withParser parser $ \pp -> do - mError <- parseChunk pp c (null cs) - case mError of - Just err -> do - loc <- getParseLocation pp - return [(FailDocument err, loc)] - Nothing -> runParser cs return $ reverse queue ++ rema runParser $ L.toChunks input 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 @@ -146,7 +146,8 @@ , parseSAXLocations , parseSAXLocationsThrowing , parseSAXThrowing - , GenericXMLString(..) ) + , GenericXMLString(..) + , setEntityDecoder ) import qualified Text.XML.Expat.SAX as SAX import Text.XML.Expat.NodeClass @@ -160,8 +161,6 @@ import Data.Monoid (Monoid,mempty,mappend) import Control.Parallel.Strategies import System.IO.Unsafe -import Foreign.C.String -import Foreign.Ptr -- | The tree representation of the XML document. @@ -274,38 +273,6 @@ instance (Functor c, List c) => MkElementClass NodeG c where mkElement name attrs children = Element name attrs children -setEntityDecoder :: (GenericXMLString tag, GenericXMLString text) - => Parser - -> IORef [Node tag text] - -> (tag -> Maybe text) - -> IO () -setEntityDecoder parser queueRef decoder = do - setUseForeignDTD parser True - setExternalEntityRefHandler parser eh - setSkippedEntityHandler parser skip - - where - text str (cur:rest) = modifyChildren (Text str:) cur : rest - text _ [] = undefined - - skip _ _ 1 = return False - skip _ entityName 0 = do - en <- textFromCString entityName - let mbt = decoder en - maybe (return False) - (\t -> do - modifyIORef queueRef $ text t - return True) - mbt - skip _ _ _ = undefined - - eh p ctx _ systemID publicID = - if systemID == nullPtr && publicID == nullPtr - then withCStringLen "" $ \c -> do - parseExternalEntityReference p ctx Nothing c - else return False - - -- | Strictly parse XML to tree. Returns error message or valid parsed tree. parse' :: (GenericXMLString tag, GenericXMLString text) => ParserOptions tag text -- ^ Parser options @@ -323,9 +290,10 @@ let emptyString = gxFromString "" stack <- newIORef [Element emptyString [] []] - maybe (return ()) - (setEntityDecoder parser stack) - mEntityDecoder + case mEntityDecoder of + Just deco -> setEntityDecoder parser deco $ \_ txt -> do + modifyIORef stack (text txt) + Nothing -> return () setStartElementHandler parser $ \_ cName cAttrs -> do name <- textFromCString cName diff --git a/hexpat.cabal b/hexpat.cabal --- a/hexpat.cabal +++ b/hexpat.cabal @@ -1,6 +1,6 @@ Cabal-Version: >= 1.6 Name: hexpat -Version: 0.15 +Version: 0.15.1 Synopsis: wrapper for expat, the fast XML parser Description: This package provides a general purpose Haskell XML library using Expat to @@ -40,7 +40,7 @@ Ensure @libexpat.dll@ can be found in your system PATH (or copy it into your executable's directory). . ChangeLog: 0.15 changes intended to fix a (rare) \"error: a C finalizer called back into Haskell.\" - that seemed only to happen only on ghc6.12.X. + that seemed only to happen only on ghc6.12.X; 0.15.1 Fix broken Annotated parse. Category: XML License: BSD3 License-File: LICENSE