diff --git a/Text/XML/Expat/Annotated.hs b/Text/XML/Expat/Annotated.hs --- a/Text/XML/Expat/Annotated.hs +++ b/Text/XML/Expat/Annotated.hs @@ -49,24 +49,10 @@ saxToTreeG, -- * Abstraction of string types - GenericXMLString(..), - - -- * Deprecated - eAttrs, - parseSAX, - parseSAXThrowing, - parseSAXLocations, - parseSAXLocationsThrowing, - parseTree, - parseTree', - parseTreeThrowing, - unannotate, - ParserOptions, - defaultParserOptions + GenericXMLString(..) ) where -import Control.Arrow -import qualified Text.XML.Expat.Tree as Tree +import Control.Arrow (first) import Text.XML.Expat.SAX ( Encoding(..) , GenericXMLString(..) , ParseOptions(..) @@ -74,13 +60,7 @@ , SAXEvent(..) , XMLParseError(..) , XMLParseException(..) - , XMLParseLocation(..) - , parseSAX - , parseSAXThrowing - , parseSAXLocations - , parseSAXLocationsThrowing - , ParserOptions - , defaultParserOptions ) + , XMLParseLocation(..) ) import qualified Text.XML.Expat.SAX as SAX import Text.XML.Expat.Internal.Namespaced import Text.XML.Expat.Internal.NodeClass @@ -99,8 +79,8 @@ -- that it has an extra piece of information of your choice attached to each -- Element. -- --- @c@ is the container type for the element's children, which is [] in the --- @hexpat@ package, and a monadic list type for @hexpat-iteratee@. +-- @c@ is the container type for the element's children, which would normally be [], +-- but could potentially be a monadic list type to allow for chunked I/O. -- -- @tag@ is the tag type, which can either be one of several string types, -- or a special type from the @Text.XML.Expat.Namespaced@ or @@ -153,10 +133,6 @@ Text t1 == Text t2 = t1 == t2 _ == _ = False -eAttrs :: Node a tag text -> [(tag, text)] -{-# DEPRECATED eAttrs "use eAttributes instead" #-} -eAttrs = eAttributes - instance (NFData tag, NFData text, NFData a) => NFData (NodeG a [] tag text) where rnf (Element nam att chi ann) = rnf (nam, att, chi, ann) rnf (Text txt) = rnf txt @@ -223,13 +199,6 @@ instance (Functor c, List c) => MkElementClass (NodeG ()) c where mkElement name attrs children = Element name attrs children () --- | Convert an annotated tree (/Annotated/ module) into a non-annotated --- tree (/Tree/ module). DEPRECATED in favour of 'fromElement'. -unannotate :: Functor c => NodeG a c tag text -> Tree.NodeG c tag text -{-# DEPRECATED unannotate "use fromElement instead" #-} -unannotate (Element na at ch _) = (Tree.Element na at (fmap unannotate ch)) -unannotate (Text t) = Tree.Text t - -- | Type alias for an annotated node with unqualified tag names where -- tag and text are the same string type type UNode a text = Node a text text @@ -339,18 +308,6 @@ -> ItemM l (NodeG XMLParseLocation l tag text) parseG opts = saxToTreeG . SAX.parseLocationsG opts --- | DEPRECATED: Use 'parse' instead. --- --- Lazily parse XML to tree. Note that forcing the XMLParseError return value --- will force the entire parse. Therefore, to ensure lazy operation, don't --- check the error status until you have processed the tree. -parseTree :: (GenericXMLString tag, GenericXMLString text) => - Maybe Encoding -- ^ Optional encoding override - -> L.ByteString -- ^ Input text (a lazy ByteString) - -> (LNode tag text, Maybe XMLParseError) -{-# DEPRECATED parseTree "use Text.XML.Annotated.parse instead" #-} -parseTree mEnc = parse (ParseOptions mEnc Nothing) - -- | Lazily parse XML to tree. In the event of an error, throw 'XMLParseException'. -- -- @parseThrowing@ can throw an exception from pure code, which is generally a bad @@ -364,32 +321,12 @@ -> LNode tag text parseThrowing opts bs = fst $ saxToTree $ SAX.parseLocationsThrowing opts bs --- | DEPRECATED: use 'parseThrowing' instead --- --- Lazily parse XML to tree. In the event of an error, throw 'XMLParseException'. -parseTreeThrowing :: (GenericXMLString tag, GenericXMLString text) => - Maybe Encoding -- ^ Optional encoding override - -> L.ByteString -- ^ Input text (a lazy ByteString) - -> LNode tag text -{-# DEPRECATED parseTreeThrowing "use Text.XML.Annotated.parseThrowing instead" #-} -parseTreeThrowing mEnc = parseThrowing (ParseOptions mEnc Nothing) - -- | Strictly parse XML to tree. Returns error message or valid parsed tree. parse' :: (GenericXMLString tag, GenericXMLString text) => ParseOptions tag text -- ^ Parse options -> B.ByteString -- ^ Input text (a strict ByteString) -> Either XMLParseError (LNode tag text) -parse' opts bs = case parse opts (L.fromChunks [bs]) of - (_, Just err) -> Left err - (root, Nothing) -> Right root - --- | DEPRECATED: use 'parse' instead. --- --- Strictly parse XML to tree. Returns error message or valid parsed tree. -parseTree' :: (GenericXMLString tag, GenericXMLString text) => - Maybe Encoding -- ^ Optional encoding override - -> B.ByteString -- ^ Input text (a strict ByteString) - -> Either XMLParseError (LNode tag text) -{-# DEPRECATED parseTree' "use Text.XML.Expat.parse' instead" #-} -parseTree' mEnc = parse' (ParseOptions mEnc Nothing) +parse' opts doc = case parse opts (L.fromChunks [doc]) of + (xml, Nothing) -> Right xml + (_, Just err) -> Left err diff --git a/Text/XML/Expat/Format.hs b/Text/XML/Expat/Format.hs --- a/Text/XML/Expat/Format.hs +++ b/Text/XML/Expat/Format.hs @@ -28,9 +28,6 @@ formatDocument, formatDocument', formatDocumentG, - -- * Deprecated names - formatTree, - formatTree', -- * Low level xmlHeader, treeToSAX, @@ -58,12 +55,6 @@ import Data.Text (Text) import Text.XML.Expat.Tree (UNode) --- | DEPRECATED: Renamed to 'format'. -formatTree :: (NodeClass n [], GenericXMLString tag, GenericXMLString text) => - n [] tag text - -> L.ByteString -formatTree = format - -- | Format document with n [] tag text @@ -77,12 +68,6 @@ n c tag text -> c B.ByteString formatG node = cons xmlHeader $ formatNodeG node - --- | DEPRECATED: Renamed to 'format''. -formatTree' :: (NodeClass n [], GenericXMLString tag, GenericXMLString text) => - n [] tag text - -> B.ByteString -formatTree' = B.concat . L.toChunks . formatTree -- | Format document with diff --git a/Text/XML/Expat/IO.hs b/Text/XML/Expat/IO.hs deleted file mode 100644 --- a/Text/XML/Expat/IO.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# OPTIONS_HADDOCK hide #-} -module Text.XML.Expat.IO - {-# DEPRECATED "Renamed to Text.XML.Expat.Internal.IO" #-} - ( - module Text.XML.Expat.Internal.IO - ) where - -import Text.XML.Expat.Internal.IO - diff --git a/Text/XML/Expat/Internal/Glue.c b/Text/XML/Expat/Internal/Glue.c new file mode 100644 --- /dev/null +++ b/Text/XML/Expat/Internal/Glue.c @@ -0,0 +1,245 @@ +#include +#include +#include +#include + +typedef struct { + XML_Parser parser; + XML_Char* (*decoder)(const XML_Char*); + int locations; +} MyParser; + +typedef struct { + size_t offset; + size_t capacity; + uint8_t* block; + MyParser* mp; +} Block; + +/*! + * Allocate the specified amount of room in the buffer. + */ +static void* alloc(Block* blk, size_t room) +{ + size_t minCapacity = blk->offset + room; + size_t start = blk->offset; + { + int changed = 0; + size_t capacity = blk->capacity; + while (capacity < minCapacity) { + capacity = capacity * 2; + changed = 1; + } + if (changed) { + blk->capacity = capacity; + blk->block = realloc(blk->block, capacity); + } + } + blk->offset += room; + return blk->block + start; +} + +static void pushType(Block* blk, uint32_t type) +{ + *(uint32_t*)alloc(blk, 4) = type; + if (blk->mp->locations) { + int64_t* loc = alloc(blk, 32); + loc[0] = (int64_t)XML_GetCurrentLineNumber(blk->mp->parser); + loc[1] = (int64_t)XML_GetCurrentColumnNumber(blk->mp->parser); + loc[2] = (int64_t)XML_GetCurrentByteIndex(blk->mp->parser); + loc[3] = (int64_t)XML_GetCurrentByteCount(blk->mp->parser); + } +} + +#define ROUND_UP_32(x) (((x) + 3) & ~3) + +static void startElement( + void *userData, + const XML_Char *name, + const XML_Char **atts) +{ + Block* blk = userData; + size_t nameLen = strlen(name) + 1; + size_t nAtts, i; + for (nAtts = 0; atts[nAtts] != NULL; nAtts += 2) ; + pushType(blk, 1); + *(uint32_t*)alloc(blk, 4) = nAtts; + memcpy(alloc(blk, nameLen), name, nameLen); + for (i = 0; i < nAtts; i++) { + size_t attLen = strlen(atts[i]) + 1; + memcpy(alloc(blk, attLen), atts[i], attLen); + } + blk->offset = ROUND_UP_32(blk->offset); +} + +static void endElement(void *userData, const XML_Char *name) +{ + Block* blk = userData; + size_t nameLen = strlen(name) + 1; + pushType(blk, 2); + memcpy(alloc(blk, nameLen), name, nameLen); + blk->offset = ROUND_UP_32(blk->offset); +} + +static void characterData( + void *userData, + const XML_Char *s, + int len) +{ + Block* blk = userData; + pushType(blk, 3); + *(uint32_t*)alloc(blk, 4) = len; + memcpy(alloc(blk, (size_t)len), s, (size_t)len); + blk->offset = ROUND_UP_32(blk->offset); +} + +static void xmlDeclHandler(void *userData, + const XML_Char *version, + const XML_Char *encoding, + int standalone) +{ + Block* blk = userData; + int verLen = strlen(version) + 1; + pushType(blk, 4); + memcpy(alloc(blk, verLen), version, verLen); + if (encoding != NULL) { + int encLen = strlen(encoding)+1; + uint8_t* pEnc = alloc(blk, encLen+1); + pEnc[0] = 1; + memcpy(pEnc+1, encoding, encLen); + } + else + *(uint8_t*)alloc(blk, 1) = 0; + *(int8_t*)alloc(blk, 1) = (int8_t)standalone; + blk->offset = ROUND_UP_32(blk->offset); +} + +static void startCData(void* userData) +{ + Block* blk = userData; + pushType(blk, 5); +} + +static void endCData(void* userData) +{ + Block* blk = userData; + pushType(blk, 6); +} + +static void processingInstruction(void *userData, const XML_Char *target, const XML_Char *data) +{ + Block* blk = userData; + int targetLen = strlen(target) + 1; + int dataLen = strlen(data) + 1; + pushType(blk, 7); + memcpy(alloc(blk, targetLen), target, targetLen); + memcpy(alloc(blk, dataLen), data, dataLen); + blk->offset = ROUND_UP_32(blk->offset); +} + +static void comment(void* userData, const XML_Char *text) +{ + Block* blk = userData; + int textLen = strlen(text) + 1; + pushType(blk, 8); + memcpy(alloc(blk, textLen), text, textLen); + blk->offset = ROUND_UP_32(blk->offset); +} + +MyParser* hexpatNewParser(const XML_Char* encoding, int locations) +{ + MyParser* mp = malloc(sizeof(MyParser)); + XML_Parser p = XML_ParserCreate(encoding); + XML_SetStartElementHandler(p, startElement); + XML_SetEndElementHandler(p, endElement); + XML_SetCharacterDataHandler(p, characterData); + XML_SetXmlDeclHandler(p, xmlDeclHandler); + XML_SetCdataSectionHandler(p, startCData, endCData); + XML_SetProcessingInstructionHandler(p, processingInstruction); + XML_SetCommentHandler(p, comment); + mp->parser = p; + mp->locations = locations; + return mp; +} + +void hexpatFreeParser(MyParser* mp) +{ + XML_ParserFree(mp->parser); + free(mp); +} + +static int externalEntityRef(XML_Parser parser, + const XML_Char *context, + const XML_Char *base, + const XML_Char *systemId, + const XML_Char *publicId) +{ + if (systemId == NULL && publicId == NULL) { + XML_Parser eep = XML_ExternalEntityParserCreate(parser, context, NULL); + enum XML_Status ret = XML_Parse(eep, "", 0, XML_TRUE); + if (ret == XML_STATUS_OK) { + XML_ParserFree(eep); + } + else { + XML_ParserFree(eep); + XML_StopParser(parser, 0); + } + } + else + XML_StopParser(parser, 0); +} + +static void skippedEntity(void *userData, + const XML_Char *entityName, + int is_parameter_entity) +{ + Block* blk = userData; + if (is_parameter_entity) + XML_StopParser(blk->mp->parser, 0); + else { + XML_Char* out = blk->mp->decoder(entityName); + if (out != NULL) { + characterData(blk, out, strlen(out)); + free(out); + } + else + XML_StopParser(blk->mp->parser, 0); + } +} + +enum XML_Status hexpatParse( + MyParser* mp, + const char* s, + int len, + int isFinal, + uint8_t** buffer, + int* length) +{ + enum XML_Status ret; + Block blk; + blk.offset = 0; + blk.capacity = 256; + blk.block = malloc(blk.capacity); + blk.mp = mp; + XML_SetUserData(mp->parser, &blk); + ret = XML_Parse(mp->parser, s, len, isFinal); + *(uint32_t*)alloc(&blk, 4) = 0; + *buffer = blk.block; + *length = (int)blk.offset; + return ret; +} + +void hexpatSetEntityHandler( + MyParser* mp, + XML_Char* (*decoder)(const XML_Char*)) +{ + mp->decoder = decoder; + XML_UseForeignDTD(mp->parser, XML_TRUE); + XML_SetExternalEntityRefHandler(mp->parser, externalEntityRef); + XML_SetSkippedEntityHandler(mp->parser, skippedEntity); +} + +XML_Parser hexpatGetParser(MyParser* mp) +{ + return mp->parser; +} diff --git a/Text/XML/Expat/Internal/IO.hs b/Text/XML/Expat/Internal/IO.hs --- a/Text/XML/Expat/Internal/IO.hs +++ b/Text/XML/Expat/Internal/IO.hs @@ -1,94 +1,32 @@ {-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-} +{-# OPTIONS_GHC -fno-cse -fno-full-laziness #-} + -- | Low-level interface to Expat. Unless speed is paramount, this should -- normally be avoided in favour of the interfaces provided by --- 'Text.XML.Expat.SAX' and 'Text.XML.Expat.Tree', etc. 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', 'parse'' or 'parseChunk'. Some of --- these functions must be wrapped in 'withParser'. - +-- 'Text.XML.Expat.SAX' and 'Text.XML.Expat.Tree', etc. module Text.XML.Expat.Internal.IO ( - -- ** Parser Setup - Parser, newParser, - - -- ** Parsing - parse, parse', - withParser, - ParserPtr, Parser_struct, - parseChunk, + HParser, + hexpatNewParser, + encodingToString, Encoding(..), XMLParseError(..), - getParseLocation, - XMLParseLocation(..), - - -- ** Parser Callbacks - XMLDeclarationHandler, - StartElementHandler, - EndElementHandler, - CharacterDataHandler, - ExternalEntityRefHandler, - SkippedEntityHandler, - StartCDataHandler, - EndCDataHandler, - CommentHandler, - ProcessingInstructionHandler, - setXMLDeclarationHandler, - setStartElementHandler, - setEndElementHandler, - setCharacterDataHandler, - setStartCDataHandler, - setEndCDataHandler, - setProcessingInstructionHandler, - setCommentHandler, - setExternalEntityRefHandler, - setSkippedEntityHandler, - setUseForeignDTD, - - -- ** Lower-level interface - parseExternalEntityReference, - ExpatHandlers, - - -- ** Helpers - encodingToString + XMLParseLocation(..) ) where -import Control.Concurrent -import Control.Exception (bracket) +import Control.Applicative import Control.DeepSeq -import Control.Monad -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as BSL -import Data.IORef -import Foreign hiding (unsafePerformIO) +import qualified Data.ByteString as B +import qualified Data.ByteString.Internal as I +import Data.Int +import Data.Word +import Foreign import Foreign.C -import System.IO.Unsafe (unsafePerformIO) --- |Opaque parser type. data Parser_struct type ParserPtr = Ptr Parser_struct -data Parser = Parser - { _parserObj :: ForeignPtr Parser_struct - , _xmlDeclarationHandler :: IORef CXMLDeclarationHandler - , _startElementHandler :: IORef CStartElementHandler - , _endElementHandler :: IORef CEndElementHandler - , _cdataHandler :: IORef CCharacterDataHandler - , _externalEntityRefHandler :: IORef (Maybe CExternalEntityRefHandler) - , _skippedEntityHandler :: IORef (Maybe CSkippedEntityHandler) - , _startCDataHandler :: IORef CStartCDataHandler - , _endCDataHandler :: IORef CEndCDataHandler - , _processingInstructionHandler :: IORef CProcessingInstructionHandler - , _commentHandler :: IORef CCommentHandler - } -instance Show Parser where - showsPrec _ (Parser fp _ _ _ _ _ _ _ _ _ _) = showsPrec 0 fp - --- |Encoding types available for the document encoding. data Encoding = ASCII | UTF8 | UTF16 | ISO88591 encodingToString :: Encoding -> String encodingToString ASCII = "US-ASCII" @@ -100,99 +38,16 @@ withOptEncoding Nothing f = f nullPtr withOptEncoding (Just enc) f = withCString (encodingToString enc) f - -parserCreate :: Maybe Encoding -> IO (ParserPtr) -parserCreate a1 = - withOptEncoding a1 $ \a1' -> do - pp <- parserCreate'_ a1' - xmlSetUserData pp pp - return pp - --- | Create a 'Parser'. -newParser :: Maybe Encoding -> IO Parser -newParser enc = do - ptr <- parserCreate enc - fptr <- newForeignPtr parserFree ptr - nullXMLDeclH <- newIORef nullCXMLDeclarationHandler - nullStartH <- newIORef nullCStartElementHandler - nullEndH <- newIORef nullCEndElementHandler - nullCharH <- newIORef nullCCharacterDataHandler - extH <- newIORef Nothing - skipH <- newIORef Nothing - nullSCDataH <- newIORef nullCStartCDataHandler - nullECDataH <- newIORef nullCEndCDataHandler - nullPIH <- newIORef nullCProcessingInstructionHandler - nullCommentH <- newIORef nullCCommentHandler - - return $ Parser fptr nullXMLDeclH nullStartH nullEndH nullCharH extH skipH - nullSCDataH nullECDataH nullPIH nullCommentH - -setUseForeignDTD :: Parser -> Bool -> IO () -setUseForeignDTD p b = withParser p $ \p' -> xmlUseForeignDTD p' b' - where - b' = if b then 1 else 0 - -- ByteString.useAsCStringLen is almost what we need, but C2HS wants a CInt -- instead of an Int. -withBStringLen :: BS.ByteString -> ((CString, CInt) -> IO a) -> IO a +withBStringLen :: B.ByteString -> ((CString, CInt) -> IO a) -> IO a withBStringLen bs f = do - BS.useAsCStringLen bs $ \(str, len) -> f (str, fromIntegral len) + B.useAsCStringLen bs $ \(str, len) -> f (str, fromIntegral len) unStatus :: CInt -> Bool unStatus 0 = False unStatus _ = True --- |@parse data@ feeds /lazy/ ByteString data into a 'Parser'. It returns --- Nothing on success, or Just the parse error. -parse :: Parser -> BSL.ByteString -> IO (Maybe XMLParseError) -parse parser bs = withParser parser $ \pp -> do - let - doParseChunks [] = doParseChunk pp BS.empty True - doParseChunks (c:cs) = do - ok <- doParseChunk pp c False - if ok - then doParseChunks cs - else return False - ok <- doParseChunks (BSL.toChunks bs) - if ok - then return Nothing - else Just `fmap` getError pp - --- |@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 bs = withParser parser $ \pp -> do - ok <- doParseChunk pp bs True - if ok - then return Nothing - else Just `fmap` getError pp - -parseExternalEntityReference :: Parser - -> CString -- ^ context - -> Maybe Encoding -- ^ encoding - -> CStringLen -- ^ text - -> IO Bool -parseExternalEntityReference parser context encoding (text,sz) = - withParser parser $ \pp -> do - extp <- withOptEncoding encoding $ - xmlExternalEntityParserCreate pp context - e <- doParseChunk'_ extp text (fromIntegral sz) 1 - parserFree' extp - return $ e == 1 - --- |@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 :: ParserPtr - -> BS.ByteString - -> Bool - -> IO (Maybe XMLParseError) -parseChunk pp xml final = do - ok <- doParseChunk pp xml final - if ok - then return Nothing - else Just `fmap` getError pp - getError :: ParserPtr -> IO XMLParseError getError pp = do code <- xmlGetErrorCode pp @@ -201,146 +56,10 @@ loc <- getParseLocation pp return $ XMLParseError err loc -data ExpatHandlers = ExpatHandlers - (FunPtr CXMLDeclarationHandler) - (FunPtr CStartElementHandler) - (FunPtr CEndElementHandler) - (FunPtr CCharacterDataHandler) - (Maybe (FunPtr CExternalEntityRefHandler)) - (Maybe (FunPtr CSkippedEntityHandler)) - (FunPtr CStartCDataHandler) - (FunPtr CEndCDataHandler) - (FunPtr CProcessingInstructionHandler) - (FunPtr CCommentHandler) - --- | Most of the low-level functions take a ParserPtr so are required to be --- called inside @withParser@. -withParser :: Parser - -> (ParserPtr -> IO a) -- ^ Computation where parseChunk and other low-level functions may be used - -> IO a -withParser parser@(Parser fp _ _ _ _ _ _ _ _ _ _) code = withForeignPtr fp $ \pp -> do - bracket - (unsafeSetHandlers parser pp) - unsafeReleaseHandlers - (\_ -> code pp) - where - unsafeSetHandlers :: Parser -> ParserPtr -> IO ExpatHandlers - unsafeSetHandlers (Parser _ xmlDeclRef startRef endRef charRef extRef skipRef - startCDataRef endCDataRef processingInstructionRef commentRef) pp = - do - cXMLDeclH <- mkCXMLDeclarationHandler =<< readIORef xmlDeclRef - cStartH <- mkCStartElementHandler =<< readIORef startRef - cEndH <- mkCEndElementHandler =<< readIORef endRef - cCharH <- mkCCharacterDataHandler =<< readIORef charRef - mExtH <- readIORef extRef >>= - maybe (return Nothing) - (\h -> liftM Just $ mkCExternalEntityRefHandler h) - - mSkipH <- readIORef skipRef >>= - maybe (return Nothing) - (\h -> liftM Just $ mkCSkippedEntityHandler h) - - cStartCDataH <- mkCStartCDataHandler =<< readIORef startCDataRef - cEndCDataH <- mkCEndCDataHandler =<< readIORef endCDataRef - - cProcessingInstructionH <- mkCProcessingInstructionHandler =<< readIORef processingInstructionRef - cCommentH <- mkCCommentHandler =<< readIORef commentRef - - xmlSetxmldeclhandler pp cXMLDeclH - xmlSetstartelementhandler pp cStartH - xmlSetendelementhandler pp cEndH - xmlSetcharacterdatahandler pp cCharH - xmlSetstartcdatahandler pp cStartCDataH - xmlSetendcdatahandler pp cEndCDataH - xmlSetprocessinginstructionhandler pp cProcessingInstructionH - xmlSetcommenthandler pp cCommentH - maybe (return ()) - (xmlSetExternalEntityRefHandler pp) - mExtH - maybe (return ()) - (xmlSetSkippedEntityHandler pp) - mSkipH - - return $ ExpatHandlers cXMLDeclH cStartH cEndH cCharH mExtH mSkipH - cStartCDataH cEndCDataH cProcessingInstructionH cCommentH - - unsafeReleaseHandlers :: ExpatHandlers -> IO () - unsafeReleaseHandlers (ExpatHandlers cXMLDeclH cStartH cEndH cCharH mcExtH mcSkipH - cStartCDataH cEndCDataH cProcessingInstructionH cCommentH) = do - freeHaskellFunPtr cXMLDeclH - freeHaskellFunPtr cStartH - freeHaskellFunPtr cEndH - freeHaskellFunPtr cCharH - maybe (return ()) freeHaskellFunPtr mcExtH - maybe (return ()) freeHaskellFunPtr mcSkipH - freeHaskellFunPtr cStartCDataH - freeHaskellFunPtr cEndCDataH - freeHaskellFunPtr cProcessingInstructionH - freeHaskellFunPtr cCommentH - -- |Obtain C value from Haskell 'Bool'. -- cFromBool :: Num a => Bool -> a -cFromBool = fromBool - -doParseChunk :: ParserPtr -> BS.ByteString -> Bool -> IO (Bool) -doParseChunk = ensureBoundThread $ \a1 a2 a3 -> - 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') - -data WorkerIface = WorkerIface (MVar (ParserPtr, BS.ByteString, Bool)) (MVar Bool) - -workerIfaceRef :: IORef (Maybe WorkerIface) -{-# NOINLINE workerIfaceRef #-} -workerIfaceRef = unsafePerformIO $ newIORef Nothing - --- If the calling thread is not bound, we delegate to a bound thread, because --- otherwise we get a thread explosion (this is true in ghc-6.12.X). --- See test/thread-leak/ directory for a test case. -ensureBoundThread :: (ParserPtr -> BS.ByteString -> Bool -> IO Bool) - -> ParserPtr - -> BS.ByteString - -> Bool - -> IO Bool -ensureBoundThread doit p bs last = do - bound <- isCurrentThreadBound - if rtsSupportsBoundThreads && not bound - then delegate - else doit p bs last - where - delegate = do - mIface <- readIORef workerIfaceRef - case mIface of - Just iface -> pipeTo iface - Nothing -> do - inV <- newEmptyMVar - outV <- newEmptyMVar - let iface = WorkerIface inV outV - justSetItGlobally <- atomicModifyIORef workerIfaceRef $ \mIface -> - case mIface of - Just _ -> (mIface, False) - Nothing -> (Just iface, True) - if justSetItGlobally - then do - _ <- forkOS $ worker iface - pipeTo iface - else - -- If it wasn't changed, then this is because we got a race - -- condition with another thread. We resolve this by trying - -- again. We'll succeed on the second attempt. The mvars - -- we allocated here will be GC'd. - delegate - - pipeTo (WorkerIface inV outV) = - putMVar inV (p, bs, last) >> takeMVar outV - - worker (WorkerIface inV outV) = forever $ - putMVar outV =<< uncurry3 doit =<< takeMVar inV - where - uncurry3 f (a, b, c) = f a b c +cFromBool = fromBool -- | Parse error, consisting of message text and error location data XMLParseError = XMLParseError String XMLParseLocation deriving (Eq, Show) @@ -373,373 +92,6 @@ xmlByteCount = fromIntegral count } --- | The type of the \"XML declaration\" callback. Parameters are version, --- encoding (which can be nullPtr), and standalone declaration, where -1 = no --- declaration, 0 = "no" and 1 = "yes". Return True to continue parsing as --- normal, or False to terminate the parse. -type XMLDeclarationHandler = ParserPtr -> CString -> CString -> CInt -> IO Bool - --- | 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 = ParserPtr -> 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 = ParserPtr -> 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 = ParserPtr -> CStringLen -> IO Bool - --- | The type of the \"start cdata\" callback. Return True to continue --- parsing as normal, or False to terminate the parse. -type StartCDataHandler = ParserPtr -> IO Bool - --- | The type of the \"end cdata\" callback. Return True to continue --- parsing as normal, or False to terminate the parse. -type EndCDataHandler = ParserPtr -> IO Bool - --- | The type of the \"processing instruction\" callback. The first parameter --- is the first word in the processing instruction. The second parameter is --- the rest of the characters in the processing instruction after skipping all --- whitespace after the initial word. Return True to continue parsing as normal, --- or False to terminate the parse. -type ProcessingInstructionHandler = ParserPtr -> CString -> CString -> IO Bool - --- | The type of the \"comment\" callback. The parameter is the comment text. --- Return True to continue parsing as normal, or False to terminate the parse. -type CommentHandler = ParserPtr -> CString -> IO Bool - --- | The type of the \"external entity reference\" callback. See the expat --- documentation. -type ExternalEntityRefHandler = Parser - -> CString -- context - -> CString -- base - -> CString -- systemID - -> CString -- publicID - -> IO Bool - --- | Set a skipped entity handler. This is called in two situations: --- --- 1. An entity reference is encountered for which no declaration has been read --- and this is not an error. --- --- 2. An internal entity reference is read, but not expanded, because --- @XML_SetDefaultHandler@ has been called. -type SkippedEntityHandler = ParserPtr - -> CString -- entityName - -> Int -- is a parameter entity? - -> IO Bool - - -type CXMLDeclarationHandler = ParserPtr -> CString -> CString -> CInt -> IO () - -nullCXMLDeclarationHandler :: CXMLDeclarationHandler -nullCXMLDeclarationHandler _ _ _ _ = return () - -foreign import ccall safe "wrapper" - mkCXMLDeclarationHandler :: CXMLDeclarationHandler - -> IO (FunPtr CXMLDeclarationHandler) - -wrapXMLDeclarationHandler :: Parser -> XMLDeclarationHandler -> CXMLDeclarationHandler -wrapXMLDeclarationHandler parser handler = h - where - h pp ver enc sd | ver /= nullPtr = do - stillRunning <- handler pp ver enc sd - unless stillRunning $ stopp parser - {- From expat.h: - The XML declaration handler is called for *both* XML declarations - and text declarations. The way to distinguish is that the version - parameter will be NULL for text declarations. - -} - h _ _ _ _ = return () -- text declaration (ignore) - --- | Attach a XMLDeclarationHandler to a Parser. -setXMLDeclarationHandler :: Parser -> XMLDeclarationHandler -> IO () -setXMLDeclarationHandler parser@(Parser _ xmlDeclRef _ _ _ _ _ _ _ _ _) handler = - writeIORef xmlDeclRef $ wrapXMLDeclarationHandler parser handler - - -type CStartElementHandler = ParserPtr -> CString -> Ptr CString -> IO () - -nullCStartElementHandler :: CStartElementHandler -nullCStartElementHandler _ _ _ = return () - -foreign import ccall safe "wrapper" - mkCStartElementHandler :: CStartElementHandler - -> IO (FunPtr CStartElementHandler) - -wrapStartElementHandler :: Parser -> StartElementHandler -> CStartElementHandler -wrapStartElementHandler parser handler = h - where - h pp cname cattrs = do - cattrlist <- peekArray0 nullPtr cattrs - stillRunning <- handler pp cname (pairwise cattrlist) - unless stillRunning $ stopp parser - --- | Attach a StartElementHandler to a Parser. -setStartElementHandler :: Parser -> StartElementHandler -> IO () -setStartElementHandler parser@(Parser _ _ startRef _ _ _ _ _ _ _ _) handler = - writeIORef startRef $ wrapStartElementHandler parser handler - - -type CEndElementHandler = ParserPtr -> CString -> IO () - -nullCEndElementHandler :: CEndElementHandler -nullCEndElementHandler _ _ = return () - -foreign import ccall safe "wrapper" - mkCEndElementHandler :: CEndElementHandler - -> IO (FunPtr CEndElementHandler) -wrapEndElementHandler :: Parser -> EndElementHandler -> CEndElementHandler -wrapEndElementHandler parser handler = h - where - h pp cname = do - stillRunning <- handler pp cname - unless stillRunning $ stopp parser - --- | Attach an EndElementHandler to a Parser. -setEndElementHandler :: Parser -> EndElementHandler -> IO () -setEndElementHandler parser@(Parser _ _ _ endRef _ _ _ _ _ _ _) handler = - writeIORef endRef $ wrapEndElementHandler parser handler - - -type CCharacterDataHandler = ParserPtr -> CString -> CInt -> IO () - -nullCCharacterDataHandler :: CCharacterDataHandler -nullCCharacterDataHandler _ _ _ = return () - -foreign import ccall safe "wrapper" - mkCCharacterDataHandler :: CCharacterDataHandler - -> IO (FunPtr CCharacterDataHandler) -wrapCharacterDataHandler :: Parser -> CharacterDataHandler -> CCharacterDataHandler -wrapCharacterDataHandler parser handler = h - where - h pp cdata len = do - stillRunning <- handler pp (cdata, fromIntegral len) - unless stillRunning $ stopp parser - --- | Attach an CharacterDataHandler to a Parser. -setCharacterDataHandler :: Parser -> CharacterDataHandler -> IO () -setCharacterDataHandler parser@(Parser _ _ _ _ charRef _ _ _ _ _ _) handler = - writeIORef charRef $ wrapCharacterDataHandler parser handler - - -type CStartCDataHandler = ParserPtr -> IO () - -nullCStartCDataHandler :: CStartCDataHandler -nullCStartCDataHandler _ = return () - -foreign import ccall safe "wrapper" - mkCStartCDataHandler :: CStartCDataHandler - -> IO (FunPtr CStartCDataHandler) - -wrapStartCDataHandler :: Parser -> StartCDataHandler -> CStartCDataHandler -wrapStartCDataHandler parser handler = h - where - h pp = do - stillRunning <- handler pp - unless stillRunning $ stopp parser - --- | Attach a StartCDataHandler to a Parser. -setStartCDataHandler :: Parser -> StartCDataHandler -> IO () -setStartCDataHandler parser@(Parser _ _ _ _ _ _ _ startCData _ _ _) handler = - writeIORef startCData $ wrapStartCDataHandler parser handler - - -type CEndCDataHandler = ParserPtr -> IO () - -nullCEndCDataHandler :: CEndCDataHandler -nullCEndCDataHandler _ = return () - -foreign import ccall safe "wrapper" - mkCEndCDataHandler :: CEndCDataHandler - -> IO (FunPtr CEndCDataHandler) - -wrapEndCDataHandler :: Parser -> EndCDataHandler -> CEndCDataHandler -wrapEndCDataHandler parser handler = h - where - h pp = do - stillRunning <- handler pp - unless stillRunning $ stopp parser - --- | Attach a EndCDataHandler to a Parser. -setEndCDataHandler :: Parser -> EndCDataHandler -> IO () -setEndCDataHandler parser@(Parser _ _ _ _ _ _ _ _ endCData _ _) handler = - writeIORef endCData $ wrapEndCDataHandler parser handler - - -type CProcessingInstructionHandler = ParserPtr -> CString -> CString -> IO () - -nullCProcessingInstructionHandler :: CProcessingInstructionHandler -nullCProcessingInstructionHandler _ _ _ = return () - -foreign import ccall safe "wrapper" - mkCProcessingInstructionHandler :: CProcessingInstructionHandler - -> IO (FunPtr CProcessingInstructionHandler) - -wrapProcessingInstructionHandler :: Parser -> ProcessingInstructionHandler -> CProcessingInstructionHandler -wrapProcessingInstructionHandler parser handler = h - where - h pp ctarget cdata = do - stillRunning <- handler pp ctarget cdata - unless stillRunning $ stopp parser - --- | Attach a ProcessingInstructionHandler to a Parser. -setProcessingInstructionHandler :: Parser -> ProcessingInstructionHandler -> IO () -setProcessingInstructionHandler parser@(Parser _ _ _ _ _ _ _ _ _ piRef _) handler = - writeIORef piRef $ wrapProcessingInstructionHandler parser handler - - -type CCommentHandler = ParserPtr -> CString -> IO () - -nullCCommentHandler :: CCommentHandler -nullCCommentHandler _ _ = return () - -foreign import ccall safe "wrapper" - mkCCommentHandler :: CCommentHandler - -> IO (FunPtr CCommentHandler) - -wrapCommentHandler :: Parser -> CommentHandler -> CCommentHandler -wrapCommentHandler parser handler = h - where - h pp cdata = do - stillRunning <- handler pp cdata - unless stillRunning $ stopp parser - --- | Attach a CommentHandler to a Parser. -setCommentHandler :: Parser -> CommentHandler -> IO () -setCommentHandler parser@(Parser _ _ _ _ _ _ _ _ _ _ commentRef) handler = - writeIORef commentRef $ wrapCommentHandler parser handler - - -pairwise :: [a] -> [(a,a)] -pairwise (x1:x2:xs) = (x1,x2) : pairwise xs -pairwise _ = [] - -stopp :: Parser -> IO () -stopp parser = withParser parser $ \p -> xmlStopParser p 0 - ------------------------------------------------------------------------------- --- C imports - -foreign import ccall unsafe "XML_ParserCreate" - parserCreate'_ :: Ptr CChar -> IO ParserPtr - -foreign import ccall unsafe "XML_SetUserData" - xmlSetUserData :: ParserPtr -> ParserPtr -> IO () - -foreign import ccall unsafe "XML_SetXmlDeclHandler" - xmlSetxmldeclhandler :: ParserPtr -> FunPtr CXMLDeclarationHandler -> IO () - -foreign import ccall unsafe "XML_SetStartElementHandler" - xmlSetstartelementhandler :: ParserPtr -> ((FunPtr (ParserPtr -> ((Ptr CChar) -> ((Ptr (Ptr CChar)) -> (IO ())))) -> (IO ()))) - -foreign import ccall unsafe "XML_SetEndElementHandler" - xmlSetendelementhandler :: ParserPtr -> ((FunPtr (ParserPtr -> ((Ptr CChar) -> (IO ()))) -> (IO ()))) - -foreign import ccall unsafe "XML_SetCharacterDataHandler" - xmlSetcharacterdatahandler :: ParserPtr -> ((FunPtr (ParserPtr -> ((Ptr CChar) -> (CInt -> (IO ())))) -> (IO ()))) - -foreign import ccall unsafe "XML_SetStartCdataSectionHandler" - xmlSetstartcdatahandler :: ParserPtr -> FunPtr CStartCDataHandler -> IO () - -foreign import ccall unsafe "XML_SetEndCdataSectionHandler" - xmlSetendcdatahandler :: ParserPtr -> FunPtr CStartCDataHandler -> IO () - -foreign import ccall unsafe "XML_SetCommentHandler" - xmlSetcommenthandler :: ParserPtr -> ((FunPtr (ParserPtr -> ((Ptr CChar) -> (IO ()))) -> (IO ()))) - -foreign import ccall unsafe "XML_SetProcessingInstructionHandler" - xmlSetprocessinginstructionhandler :: ParserPtr -> ((FunPtr (ParserPtr -> ((Ptr CChar) -> ((Ptr CChar) -> (IO ())))) -> (IO ()))) - -foreign import ccall safe "XML_Parse" - doParseChunk'_ :: ParserPtr -> ((Ptr CChar) -> (CInt -> (CInt -> (IO CInt)))) - -foreign import ccall unsafe "XML_UseForeignDTD" - xmlUseForeignDTD :: ParserPtr -- ^ parser - -> CChar -- ^ use foreign DTD? (external entity ref - -- handler will be called with publicID & - -- systemID set to null - -> IO () - -foreign import ccall "&XML_ParserFree" parserFree :: FunPtr (ParserPtr -> IO ()) -foreign import ccall "XML_ParserFree" parserFree' :: ParserPtr -> IO () - -type CExternalEntityRefHandler = ParserPtr -- parser - -> Ptr CChar -- context - -> Ptr CChar -- base - -> Ptr CChar -- systemID - -> Ptr CChar -- publicID - -> IO () - -foreign import ccall unsafe "wrapper" - mkCExternalEntityRefHandler :: CExternalEntityRefHandler - -> IO (FunPtr CExternalEntityRefHandler) - - -foreign import ccall unsafe "XML_SetExternalEntityRefHandler" - xmlSetExternalEntityRefHandler :: ParserPtr - -> FunPtr CExternalEntityRefHandler - -> IO () - -foreign import ccall unsafe "XML_SetSkippedEntityHandler" - xmlSetSkippedEntityHandler :: ParserPtr - -> FunPtr CSkippedEntityHandler - -> IO () - -foreign import ccall unsafe "XML_ExternalEntityParserCreate" - xmlExternalEntityParserCreate :: ParserPtr - -> CString -- ^ context - -> CString -- ^ encoding - -> IO ParserPtr - -type CSkippedEntityHandler = ParserPtr -- user data pointer - -> CString -- entity name - -> CInt -- is a parameter entity? - -> IO () - -foreign import ccall safe "wrapper" - mkCSkippedEntityHandler :: CSkippedEntityHandler - -> IO (FunPtr CSkippedEntityHandler) - - -wrapExternalEntityRefHandler :: Parser - -> ExternalEntityRefHandler - -> CExternalEntityRefHandler -wrapExternalEntityRefHandler parser handler = h - where - h _ context base systemID publicID = do - stillRunning <- handler parser context base systemID publicID - unless stillRunning $ stopp parser - - -wrapSkippedEntityHandler :: Parser - -> SkippedEntityHandler - -> CSkippedEntityHandler -wrapSkippedEntityHandler parser handler = h - where - h pp entityName i = do - stillRunning <- handler pp entityName (fromIntegral i) - unless stillRunning $ stopp parser - - -setExternalEntityRefHandler :: Parser -> ExternalEntityRefHandler -> IO () -setExternalEntityRefHandler parser h = - writeIORef ref $ Just $ wrapExternalEntityRefHandler parser h - where - ref = _externalEntityRefHandler parser - -setSkippedEntityHandler :: Parser -> SkippedEntityHandler -> IO () -setSkippedEntityHandler parser h = - writeIORef ref $ Just $ wrapSkippedEntityHandler parser h - where - ref = _skippedEntityHandler parser - -- Note on word sizes: -- -- on expat 2.0: @@ -774,6 +126,96 @@ :: ParserPtr -> IO CInt foreign import ccall unsafe "expat.h XML_ErrorString" xmlErrorString :: CInt -> IO CString -foreign import ccall unsafe "expat.h XML_StopParser" xmlStopParser - :: ParserPtr -> CInt -> IO () + +type HParser = B.ByteString -> Bool -> IO (ForeignPtr Word8, CInt, Maybe XMLParseError) + +foreign import ccall unsafe "hexpatNewParser" + _hexpatNewParser :: Ptr CChar -> CInt -> IO MyParserPtr + +foreign import ccall unsafe "hexpatGetParser" + _hexpatGetParser :: MyParserPtr -> ParserPtr + +data MyParser_struct +type MyParserPtr = Ptr MyParser_struct + +foreign import ccall "&hexpatFreeParser" hexpatFreeParser :: FunPtr (MyParserPtr -> IO ()) + +hexpatNewParser :: Maybe Encoding + -> Maybe (B.ByteString -> Maybe B.ByteString) -- ^ Entity decoder + -> Bool -- ^ Whether to include input locations + -> IO (HParser, IO XMLParseLocation) +hexpatNewParser enc mDecoder locations = + withOptEncoding enc $ \cEnc -> do + parser <- newForeignPtr hexpatFreeParser =<< _hexpatNewParser cEnc (cFromBool locations) + return (parse parser, withForeignPtr parser $ \mp -> getParseLocation $ _hexpatGetParser mp) + where + parse parser = case mDecoder of + Nothing -> \text final -> + alloca $ \ppData -> + alloca $ \pLen -> + withBStringLen text $ \(textBuf, textLen) -> + withForeignPtr parser $ \pp -> do + ok <- unStatus <$> _hexpatParseUnsafe pp textBuf textLen (cFromBool final) ppData pLen + pData <- peek ppData + len <- peek pLen + err <- if ok + then return Nothing + else Just <$> getError (_hexpatGetParser pp) + fpData <- newForeignPtr funPtrFree pData + return (fpData, len, err) + Just decoder -> \text final -> + alloca $ \ppData -> + alloca $ \pLen -> + withBStringLen text $ \(textBuf, textLen) -> + withForeignPtr parser $ \pp -> do + eh <- mkCEntityHandler . wrapCEntityHandler $ decoder + _hexpatSetEntityHandler pp eh + ok <- unStatus <$> _hexpatParseSafe pp textBuf textLen (cFromBool final) ppData pLen + freeHaskellFunPtr eh + pData <- peek ppData + len <- peek pLen + err <- if ok + then return Nothing + else Just <$> getError (_hexpatGetParser pp) + fpData <- newForeignPtr funPtrFree pData + return (fpData, len, err) + +foreign import ccall unsafe "hexpatParse" + _hexpatParseUnsafe :: MyParserPtr -> Ptr CChar -> CInt -> CInt -> Ptr (Ptr Word8) -> Ptr CInt -> IO CInt + +foreign import ccall safe "hexpatParse" + _hexpatParseSafe :: MyParserPtr -> Ptr CChar -> CInt -> CInt -> Ptr (Ptr Word8) -> Ptr CInt -> IO CInt + +type CEntityHandler = Ptr CChar -> IO (Ptr CChar) + +foreign import ccall safe "wrapper" + mkCEntityHandler :: CEntityHandler + -> IO (FunPtr CEntityHandler) + +peekByteStringLen :: CStringLen -> IO B.ByteString +{-# INLINE peekByteStringLen #-} +peekByteStringLen (cstr, len) = + I.create (fromIntegral len) $ \ptr -> + I.memcpy ptr (castPtr cstr) (fromIntegral len) + +wrapCEntityHandler :: (B.ByteString -> Maybe B.ByteString) -> CEntityHandler +wrapCEntityHandler handler = h + where + h cname = do + sz <- fromIntegral <$> I.c_strlen cname + name <- peekByteStringLen (cname, sz) + case handler name of + Just text -> do + let (fp, offset, len) = I.toForeignPtr text + withForeignPtr fp $ \ctextBS -> do + ctext <- mallocBytes (len + 1) :: IO CString + I.memcpy (castPtr ctext) (ctextBS `plusPtr` offset) (fromIntegral len) + poke (ctext `plusPtr` len) (0 :: CChar) + return ctext + Nothing -> return nullPtr + +foreign import ccall unsafe "hexpatSetEntityHandler" + _hexpatSetEntityHandler :: MyParserPtr -> FunPtr CEntityHandler -> IO () + +foreign import ccall "&free" funPtrFree :: FunPtr (Ptr Word8 -> IO ()) diff --git a/Text/XML/Expat/Namespaced.hs b/Text/XML/Expat/Namespaced.hs deleted file mode 100644 --- a/Text/XML/Expat/Namespaced.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# OPTIONS_HADDOCK hide #-} -module Text.XML.Expat.Namespaced - {-# DEPRECATED "Use Text.XML.Expat.Text or Text.XML.Expat.Annotated instead" #-} - ( - module Text.XML.Expat.Internal.Namespaced - ) where - -import Text.XML.Expat.Internal.Namespaced - diff --git a/Text/XML/Expat/NodeClass.hs b/Text/XML/Expat/NodeClass.hs deleted file mode 100644 --- a/Text/XML/Expat/NodeClass.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# OPTIONS_HADDOCK hide #-} -module Text.XML.Expat.NodeClass - {-# DEPRECATED "Use Text.XML.Expat.Text or Text.XML.Expat.Annotated instead" #-} - ( - module Text.XML.Expat.Internal.NodeClass - ) where - -import Text.XML.Expat.Internal.NodeClass - diff --git a/Text/XML/Expat/Qualified.hs b/Text/XML/Expat/Qualified.hs deleted file mode 100644 --- a/Text/XML/Expat/Qualified.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# OPTIONS_HADDOCK hide #-} -module Text.XML.Expat.Qualified - {-# DEPRECATED "Use Text.XML.Expat.Text or Text.XML.Expat.Annotated instead" #-} - ( - module Text.XML.Expat.Internal.Qualified - ) where - -import Text.XML.Expat.Internal.Qualified - 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 @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveDataTypeable, TypeSynonymInstances, CPP, ScopedTypeVariables, FlexibleInstances #-} +{-# OPTIONS_GHC -fno-cse -fno-full-laziness #-} -- hexpat, a Haskell wrapper for expat -- Copyright (C) 2008 Evan Martin @@ -16,7 +17,6 @@ ParseOptions(..), SAXEvent(..), - textFromCString, parse, parseG, parseLocations, @@ -28,41 +28,36 @@ -- * Variants that throw exceptions XMLParseException(..), - -- * Helpers - setEntityDecoder, - -- * Abstraction of string types - GenericXMLString(..), - - -- * Deprecated parse functions - parseSAX, - parseSAXLocations, - parseSAXLocationsThrowing, - parseSAXThrowing, - ParserOptions, - defaultParserOptions + GenericXMLString(..) ) where -import Text.XML.Expat.Internal.IO hiding (parse) +import Control.Concurrent.MVar +import Text.XML.Expat.Internal.IO +import Data.Bits import Data.ByteString (ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Internal as I -import Data.IORef +import Data.Int import Data.ByteString.Internal (c2w, w2c, c_strlen) import qualified Data.Monoid as M import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified Codec.Binary.UTF8.String as U8 -import Data.Typeable import Data.List.Class hiding (tail) +import Data.Typeable +import Data.Word import Control.Exception.Extensible as Exc import Control.Applicative import Control.DeepSeq import Control.Monad import System.IO.Unsafe -import Foreign.C.String +import Foreign.C +import Foreign.ForeignPtr +import Foreign.Marshal.Array import Foreign.Ptr +import Foreign.Storable data ParseOptions tag text = ParseOptions @@ -74,18 +69,10 @@ -- be decoded into text using the supplied lookup function } -{-# DEPRECATED ParserOptions "renamed to ParseOptions" #-} -type ParserOptions tag text = ParseOptions tag text - defaultParseOptions :: ParseOptions tag text defaultParseOptions = ParseOptions Nothing Nothing --- | DEPRECATED. Renamed to defaultParseOptions. -defaultParserOptions :: ParseOptions tag text -{-# DEPRECATED defaultParserOptions "renamed to defaultParseOptions" #-} -defaultParserOptions = defaultParseOptions - -- | An abstraction for any string type you want to use as xml text (that is, -- attribute values or element text content). If you want to use a -- new string type with /hexpat/, you must make it an instance of @@ -98,7 +85,7 @@ gxHead :: s -> Char gxTail :: s -> s gxBreakOn :: Char -> s -> (s, s) - gxFromCStringLen :: CStringLen -> IO s + gxFromByteString :: B.ByteString -> s gxToByteString :: s -> B.ByteString instance GenericXMLString String where @@ -109,7 +96,7 @@ gxHead = head gxTail = tail gxBreakOn c = break (==c) - gxFromCStringLen cstr = U8.decode . B.unpack <$> peekByteStringLen cstr + gxFromByteString = U8.decode . B.unpack gxToByteString = B.pack . map c2w . U8.encodeString instance GenericXMLString B.ByteString where @@ -120,7 +107,7 @@ gxHead = w2c . B.head gxTail = B.tail gxBreakOn c = B.break (== c2w c) - gxFromCStringLen = peekByteStringLen + gxFromByteString = id gxToByteString = id instance GenericXMLString T.Text where @@ -140,16 +127,9 @@ #else gxBreakOn c = T.breakBy (==c) #endif - gxFromCStringLen cstr = TE.decodeUtf8 <$> peekByteStringLen cstr + gxFromByteString = TE.decodeUtf8 gxToByteString = TE.encodeUtf8 -peekByteStringLen :: CStringLen -> IO B.ByteString -{-# INLINE peekByteStringLen #-} -peekByteStringLen (cstr, len) = - I.create (fromIntegral len) $ \ptr -> - I.memcpy ptr (castPtr cstr) (fromIntegral len) - - data SAXEvent tag text = XMLDeclaration text (Maybe text) (Maybe Bool) | StartElement tag [(tag, text)] | @@ -173,139 +153,150 @@ rnf (Comment text) = rnf text rnf (FailDocument err) = rnf err --- | Converts a 'CString' to a 'GenericXMLString' type. -textFromCString :: GenericXMLString text => CString -> IO text -{-# INLINE textFromCString #-} -textFromCString cstr = do - 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 - -> (tag -> Maybe text) -- ^ Entity decoder - -> (ParserPtr -> text -> IO ()) -- ^ Code to insert character data into the document - -> IO () -setEntityDecoder parser decoder insertText = do - setUseForeignDTD parser True - setExternalEntityRefHandler parser eh - setSkippedEntityHandler parser skip - - where - skip _ _ 1 = return False - skip pp entityName 0 = do - en <- textFromCString entityName - let mbt = decoder en - maybe (return False) - (\t -> do - insertText pp t - return True) - mbt - skip _ _ _ = undefined - - eh pp ctx _ systemID publicID = - if systemID == nullPtr && publicID == nullPtr - then withCStringLen "" $ \c -> do - parseExternalEntityReference pp ctx Nothing c - else return False - -- | Parse a generalized list of ByteStrings containing XML to SAX events. -- In the event of an error, FailDocument is the last element of the output list. parseG :: forall tag text l . (GenericXMLString tag, GenericXMLString text, List l) => ParseOptions tag text -- ^ Parse options -> l ByteString -- ^ Input text (a lazy ByteString) -> l (SAXEvent tag text) -parseG opts inputBlocks = runParser inputBlocks parser queueRef cacheRef - where - (parser, queueRef, cacheRef) = unsafePerformIO $ do - let enc = overrideEncoding opts - let mEntityDecoder = entityDecoder opts - - parser <- newParser enc - queueRef <- newIORef [] - - case mEntityDecoder of - Just deco -> setEntityDecoder parser deco $ \_ txt -> do - modifyIORef queueRef (CharacterData txt:) - Nothing -> return () - - setXMLDeclarationHandler parser $ \_ cVer cEnc cSd -> do - ver <- textFromCString cVer - mEnc <- if cEnc == nullPtr - then return Nothing - else Just <$> textFromCString cEnc - let sd = if cSd < 0 - then Nothing - else Just $ if cSd /= 0 then True else False - modifyIORef queueRef (XMLDeclaration ver mEnc sd:) - return True - - setStartElementHandler parser $ \_ cName cAttrs -> do - name <- textFromCString cName - attrs <- forM cAttrs $ \(cAttrName,cAttrValue) -> do - attrName <- textFromCString cAttrName - attrValue <- textFromCString cAttrValue - return (attrName, attrValue) - modifyIORef queueRef (StartElement name attrs:) - return True +{-# NOINLINE parseG #-} +parseG opts inputBlocks = mapL (return . fst) $ parseImpl opts inputBlocks False noExtra failureA + where noExtra _ offset = return ((), offset) + failureA _ = return () - setEndElementHandler parser $ \_ cName -> do - name <- textFromCString cName - modifyIORef queueRef (EndElement name:) - return True +-- | Parse a generalized list of ByteStrings containing XML to SAX events. +-- In the event of an error, FailDocument is the last element of the output list. +parseLocationsG :: forall tag text l . (GenericXMLString tag, GenericXMLString text, List l) => + ParseOptions tag text -- ^ Parse options + -> l ByteString -- ^ Input text (a lazy ByteString) + -> l (SAXEvent tag text, XMLParseLocation) +{-# NOINLINE parseLocationsG #-} +parseLocationsG opts inputBlocks = parseImpl opts inputBlocks True fetchLocation id + where + fetchLocation pBuf offset = do + [a, b, c, d] <- peekArray 4 (pBuf `plusPtr` offset :: Ptr Int64) + return (XMLParseLocation a b c d, offset + 32) - setCharacterDataHandler parser $ \_ cText -> do - txt <- gxFromCStringLen cText - modifyIORef queueRef (CharacterData txt:) - return True - - setStartCDataHandler parser $ \_ -> do - modifyIORef queueRef (StartCData :) - return True - - setEndCDataHandler parser $ \_ -> do - modifyIORef queueRef (EndCData :) - return True - - setProcessingInstructionHandler parser $ \_ cTarget cText -> do - target <- textFromCString cTarget - txt <- textFromCString cText - modifyIORef queueRef (ProcessingInstruction target txt :) - return True - - setCommentHandler parser $ \_ cText -> do - txt <- textFromCString cText - modifyIORef queueRef (Comment txt :) - return True +parseImpl :: forall a tag text l . (GenericXMLString tag, GenericXMLString text, List l) => + ParseOptions tag text -- ^ Parse options + -> l ByteString -- ^ Input text (a lazy ByteString) + -> Bool -- ^ True to add locations to binary output + -> (Ptr Word8 -> Int -> IO (a, Int)) -- ^ Fetch extra data + -> (IO XMLParseLocation -> IO a) -- ^ Fetch a value for failure case + -> l (SAXEvent tag text, a) +parseImpl opts inputBlocks addLocations extra failureA = runParser inputBlocks parse cacheRef + where + (parse, getLocation, cacheRef) = unsafePerformIO $ do + (parse, getLocation) <- hexpatNewParser + (overrideEncoding opts) + ((\decode -> fmap gxToByteString . decode . gxFromByteString) <$> entityDecoder opts) + addLocations - cacheRef <- newIORef Nothing - return (parser, queueRef, cacheRef) + cacheRef <- newMVar Nothing + return (parse, getLocation, cacheRef) - runParser iblks parser queueRef cacheRef = joinL $ do + runParser iblks parse cacheRef = joinL $ do li <- runList iblks return $ unsafePerformIO $ do - mCached <- readIORef cacheRef + mCached <- takeMVar cacheRef case mCached of - Just l -> return l + Just l -> do + putMVar cacheRef mCached + return l Nothing -> do - rema <- case li of - Nil -> do - mError <- withParser parser $ \pp -> parseChunk pp B.empty True - return $ handleFailure mError mzero - Cons blk t -> unsafeInterleaveIO $ do - mError <- withParser parser $ \pp -> parseChunk pp blk False - cacheRef' <- newIORef Nothing - return $ handleFailure mError (runParser t parser queueRef cacheRef') - queue <- readIORef queueRef - writeIORef queueRef [] - let l = fromList (reverse queue) `mplus` rema - writeIORef cacheRef (Just l) + (saxen, rema) <- case li of + Nil -> do + (buf, len, mError) <- parse B.empty True + saxen <- parseBuf buf len extra + rema <- handleFailure mError mzero + return (saxen, rema) + Cons blk t -> {-unsafeInterleaveIO $-} do + (buf, len, mError) <- parse blk False + saxen <- parseBuf buf len extra + cacheRef' <- newMVar Nothing + rema <- handleFailure mError (runParser t parse cacheRef') + return (saxen, rema) + let l = fromList saxen `mplus` rema + putMVar cacheRef (Just l) return l where - handleFailure (Just err) _ = FailDocument err `cons` mzero - handleFailure Nothing l = l + handleFailure (Just err) _ = do a <- failureA getLocation + return $ (FailDocument err, a) `cons` mzero + handleFailure Nothing l = return l +parseBuf :: (GenericXMLString tag, GenericXMLString text) => + ForeignPtr Word8 -> CInt -> (Ptr Word8 -> Int -> IO (a, Int)) -> IO [(SAXEvent tag text, a)] +parseBuf buf _ processExtra = withForeignPtr buf $ \pBuf -> doit [] pBuf 0 + where + roundUp32 offset = (offset + 3) .&. complement 3 + doit acc pBuf offset0 = offset0 `seq` do + typ <- peek (pBuf `plusPtr` offset0 :: Ptr Word32) + (a, offset) <- processExtra pBuf (offset0 + 4) + case typ of + 0 -> return (reverse acc) + 1 -> do + nAtts <- peek (pBuf `plusPtr` offset :: Ptr Word32) + let pName = pBuf `plusPtr` (offset + 4) + lName <- fromIntegral <$> c_strlen pName + let name = gxFromByteString $ I.fromForeignPtr buf (offset + 4) lName + (atts, offset') <- foldM (\(atts, offset) _ -> do + let pAtt = pBuf `plusPtr` offset + lAtt <- fromIntegral <$> c_strlen pAtt + let att = gxFromByteString $ I.fromForeignPtr buf offset lAtt + offset' = offset + lAtt + 1 + pValue = pBuf `plusPtr` offset' + lValue <- fromIntegral <$> c_strlen pValue + let value = gxFromByteString $ I.fromForeignPtr buf offset' lValue + return ((att, value):atts, offset' + lValue + 1) + ) ([], offset + 4 + lName + 1) [1,3..nAtts] + doit ((StartElement name (reverse atts), a) : acc) pBuf (roundUp32 offset') + 2 -> do + let pName = pBuf `plusPtr` offset + lName <- fromIntegral <$> c_strlen pName + let name = gxFromByteString $ I.fromForeignPtr buf offset lName + offset' = offset + lName + 1 + doit ((EndElement name, a) : acc) pBuf (roundUp32 offset') + 3 -> do + len <- fromIntegral <$> peek (pBuf `plusPtr` offset :: Ptr Word32) + let text = gxFromByteString $ I.fromForeignPtr buf (offset + 4) len + offset' = offset + 4 + len + doit ((CharacterData text, a) : acc) pBuf (roundUp32 offset') + 4 -> do + let pEnc = pBuf `plusPtr` offset + lEnc <- fromIntegral <$> c_strlen pEnc + let enc = gxFromByteString $ I.fromForeignPtr buf offset lEnc + offset' = offset + lEnc + 1 + pVer = pBuf `plusPtr` offset' + pVerFirst <- peek (castPtr pVer :: Ptr Word8) + (mVer, offset'') <- case pVerFirst of + 0 -> return (Nothing, offset' + 1) + 1 -> do + lVer <- fromIntegral <$> c_strlen (pVer `plusPtr` 1) + return (Just $ gxFromByteString $ I.fromForeignPtr buf (offset' + 1) lVer, offset' + 1 + lVer + 1) + _ -> error "hexpat: bad data from C land" + cSta <- peek (pBuf `plusPtr` offset'' :: Ptr Int8) + let sta = if cSta < 0 then Nothing else + if cSta == 0 then Just False else + Just True + doit ((XMLDeclaration enc mVer sta, a) : acc) pBuf (roundUp32 (offset'' + 1)) + 5 -> doit ((StartCData, a) : acc) pBuf offset + 6 -> doit ((EndCData, a) : acc) pBuf offset + 7 -> do + let pTarget = pBuf `plusPtr` offset + lTarget <- fromIntegral <$> c_strlen pTarget + let target = gxFromByteString $ I.fromForeignPtr buf offset lTarget + offset' = offset + lTarget + 1 + pData = pBuf `plusPtr` offset' + lData <- fromIntegral <$> c_strlen pData + let dat = gxFromByteString $ I.fromForeignPtr buf offset' lData + doit ((ProcessingInstruction target dat, a) : acc) pBuf (roundUp32 (offset' + lData + 1)) + 8 -> do + let pText = pBuf `plusPtr` offset + lText <- fromIntegral <$> c_strlen pText + let text = gxFromByteString $ I.fromForeignPtr buf offset lText + doit ((Comment text, a) : acc) pBuf (roundUp32 (offset + lText + 1)) + _ -> error "hexpat: bad data from C land" + -- | 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) => @@ -315,132 +306,12 @@ parse opts input = parseG opts (L.toChunks input) --- | DEPRECATED: Use 'parse' instead. --- --- Lazily parse XML to SAX events. In the event of an error, FailDocument is --- the last element of the output list. Deprecated in favour of new --- 'Text.XML.Expat.SAX.parse' -parseSAX :: (GenericXMLString tag, GenericXMLString text) => - Maybe Encoding -- ^ Optional encoding override - -> L.ByteString -- ^ Input text (a lazy ByteString) - -> [SAXEvent tag text] -{-# DEPRECATED parseSAX "use Text.XML.Expat.SAX.parse instead" #-} -parseSAX enc = parse (ParseOptions enc Nothing) - - -- | An exception indicating an XML parse error, used by the /..Throwing/ variants. data XMLParseException = XMLParseException XMLParseError deriving (Eq, Show, Typeable) instance Exception XMLParseException where - --- | Parse a generalized list of ByteStrings containing XML to SAX events. --- In the event of an error, FailDocument is the last element of the output list. -parseLocationsG :: forall tag text l . (GenericXMLString tag, GenericXMLString text, List l) => - ParseOptions tag text -- ^ Parse options - -> l ByteString -- ^ Input text (a lazy ByteString) - -> l (SAXEvent tag text, XMLParseLocation) -parseLocationsG opts inputBlocks = runParser inputBlocks parser queueRef cacheRef - where - (parser, queueRef, cacheRef) = unsafePerformIO $ do - let enc = overrideEncoding opts - let mEntityDecoder = entityDecoder opts - - parser <- newParser enc - queueRef <- newIORef [] - - case mEntityDecoder of - Just deco -> setEntityDecoder parser deco $ \pp txt -> do - loc <- getParseLocation pp - modifyIORef queueRef ((CharacterData txt, loc):) - Nothing -> return () - - setXMLDeclarationHandler parser $ \pp cVer cEnc cSd -> do - ver <- textFromCString cVer - mEnc <- if cEnc == nullPtr - then return Nothing - else Just <$> textFromCString cEnc - let sd = if cSd < 0 - then Nothing - else Just $ if cSd /= 0 then True else False - loc <- getParseLocation pp - modifyIORef queueRef ((XMLDeclaration ver mEnc sd, loc):) - return True - - setStartElementHandler parser $ \pp cName cAttrs -> do - name <- textFromCString cName - attrs <- forM cAttrs $ \(cAttrName,cAttrValue) -> do - attrName <- textFromCString cAttrName - attrValue <- textFromCString cAttrValue - return (attrName, attrValue) - loc <- getParseLocation pp - modifyIORef queueRef ((StartElement name attrs,loc):) - return True - - setEndElementHandler parser $ \pp cName -> do - name <- textFromCString cName - loc <- getParseLocation pp - modifyIORef queueRef ((EndElement name, loc):) - return True - - setCharacterDataHandler parser $ \pp cText -> do - txt <- gxFromCStringLen cText - loc <- getParseLocation pp - modifyIORef queueRef ((CharacterData txt, loc):) - return True - - setStartCDataHandler parser $ \pp -> do - loc <- getParseLocation pp - modifyIORef queueRef ((StartCData, loc):) - return True - - setEndCDataHandler parser $ \pp -> do - loc <- getParseLocation pp - modifyIORef queueRef ((EndCData,loc):) - return True - - setProcessingInstructionHandler parser $ \pp cTarget cText -> do - target <- textFromCString cTarget - txt <- textFromCString cText - loc <- getParseLocation pp - modifyIORef queueRef ((ProcessingInstruction target txt, loc):) - return True - - setCommentHandler parser $ \pp cText -> do - txt <- textFromCString cText - loc <- getParseLocation pp - modifyIORef queueRef ((Comment txt, loc):) - return True - - cacheRef <- newIORef Nothing - return (parser, queueRef, cacheRef) - - runParser iblks parser queueRef cacheRef = joinL $ do - li <- runList iblks - return $ unsafePerformIO $ do - mCached <- readIORef cacheRef - case mCached of - Just l -> return l - Nothing -> do - rema <- case li of - Nil -> do - mError <- withParser parser $ \pp -> parseChunk pp B.empty True - handleFailure mError mzero - Cons blk t -> unsafeInterleaveIO $ do - mError <- withParser parser $ \pp -> parseChunk pp blk False - cacheRef' <- newIORef Nothing - handleFailure mError (runParser t parser queueRef cacheRef') - queue <- readIORef queueRef - writeIORef queueRef [] - let l = fromList (reverse queue) `mplus` rema - writeIORef cacheRef (Just l) - return l - where - handleFailure (Just err) _ = do loc <- withParser parser getParseLocation - return $ (FailDocument err, loc) `cons` mzero - handleFailure Nothing l = return l - -- | A variant of parseSAX that gives a document location with each SAX event. parseLocations :: (GenericXMLString tag, GenericXMLString text) => ParseOptions tag text -- ^ Parse options @@ -448,17 +319,7 @@ -> [(SAXEvent tag text, XMLParseLocation)] parseLocations opts input = parseLocationsG opts (L.toChunks input) --- | DEPRECATED: Use 'parseLocations' instead. --- --- A variant of parseSAX that gives a document location with each SAX event. -parseSAXLocations :: (GenericXMLString tag, GenericXMLString text) => - Maybe Encoding -- ^ Optional encoding override - -> L.ByteString -- ^ Input text (a lazy ByteString) - -> [(SAXEvent tag text, XMLParseLocation)] -{-# DEPRECATED parseSAXLocations "use Text.XML.Expat.SAX.parseLocations instead" #-} -parseSAXLocations enc = parseLocations (ParseOptions enc Nothing) - -- | Lazily parse XML to SAX events. In the event of an error, throw -- 'XMLParseException'. -- @@ -477,18 +338,6 @@ freakOut other = other --- | DEPRECATED: Use 'parseThrowing' instead. --- --- Lazily parse XML to SAX events. In the event of an error, throw --- 'XMLParseException'. -parseSAXThrowing :: (GenericXMLString tag, GenericXMLString text) => - Maybe Encoding -- ^ Optional encoding override - -> L.ByteString -- ^ Input text (a lazy ByteString) - -> [SAXEvent tag text] -{-# DEPRECATED parseSAXThrowing "use Text.XML.Expat.SAX.parseThrowing instead" #-} -parseSAXThrowing mEnc = parseThrowing (ParseOptions mEnc Nothing) - - -- | A variant of parseSAX that gives a document location with each SAX event. -- In the event of an error, throw 'XMLParseException'. -- @@ -505,16 +354,3 @@ where freakOut (FailDocument err, _) = Exc.throw $ XMLParseException err freakOut other = other - - --- | DEPRECATED: Used 'parseLocationsThrowing' instead. --- --- A variant of parseSAX that gives a document location with each SAX event. --- In the event of an error, throw 'XMLParseException'. -parseSAXLocationsThrowing :: (GenericXMLString tag, GenericXMLString text) => - Maybe Encoding -- ^ Optional encoding override - -> L.ByteString -- ^ Input text (a lazy ByteString) - -> [(SAXEvent tag text, XMLParseLocation)] -{-# DEPRECATED parseSAXLocationsThrowing "use Text.XML.Expat.SAX.parseLocationsThrowing instead" #-} -parseSAXLocationsThrowing mEnc = - parseLocationsThrowing (ParseOptions mEnc Nothing) 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 @@ -128,60 +128,35 @@ saxToTreeG, -- * Abstraction of string types - GenericXMLString(..), - - -- * Deprecated - eAttrs, - Nodes, - UNodes, - QNodes, - NNodes, - parseTree, - parseTree', - parseSAX, - parseSAXLocations, - parseTreeThrowing, - parseSAXThrowing, - parseSAXLocationsThrowing, - ParserOptions, - defaultParserOptions + GenericXMLString(..) ) where -import Text.XML.Expat.Internal.IO hiding (parse,parse') -import qualified Text.XML.Expat.Internal.IO as IO -import Text.XML.Expat.SAX ( ParseOptions(..) - , XMLParseException(..) - , SAXEvent(..) - , defaultParseOptions - , textFromCString - , parseSAX - , parseSAXLocations - , parseSAXLocationsThrowing - , parseSAXThrowing +import Text.XML.Expat.SAX ( Encoding(..) , GenericXMLString(..) - , setEntityDecoder - , ParserOptions - , defaultParserOptions ) + , ParseOptions(..) + , defaultParseOptions + , SAXEvent(..) + , XMLParseError(..) + , XMLParseException(..) + , XMLParseLocation(..) ) import qualified Text.XML.Expat.SAX as SAX import Text.XML.Expat.Internal.Namespaced import Text.XML.Expat.Internal.NodeClass import Text.XML.Expat.Internal.Qualified import Control.Arrow -import Control.Monad (forM, mplus, mzero) +import Control.Monad (mplus, mzero) import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as L -import Data.IORef import Data.List.Class import Data.Monoid (Monoid,mempty,mappend) import Control.DeepSeq -import System.IO.Unsafe -- | The tree representation of the XML document. -- --- @c@ is the container type for the element's children, which is [] in the --- @hexpat@ package, and a monadic list type for @hexpat-iteratee@. +-- @c@ is the container type for the element's children, which would normally be [], +-- but could potentially be a monadic list type to allow for chunked I/O. -- -- @tag@ is the tag type, which can either be one of several string types, -- or a special type from the @Text.XML.Expat.Namespaced@ or @@ -221,46 +196,17 @@ -- @ListOf (UNode Text)@. type Node tag text = NodeG [] tag text -eAttrs :: Node tag text -> [(tag, text)] -{-# DEPRECATED eAttrs "use eAttributes instead" #-} -eAttrs = eAttributes - instance (NFData tag, NFData text) => NFData (NodeG [] tag text) where rnf (Element nam att chi) = rnf (nam, att, chi) rnf (Text txt) = rnf txt --- | DEPRECATED: Use [Node tag text] instead. --- --- Type alias for nodes. -type Nodes tag text = [Node tag text] -{-# DEPRECATED Nodes "use [Node tag text] instead" #-} - --- | DEPRECATED: Use [UNode text] instead. --- --- Type alias for nodes with unqualified tag names where tag and --- text are the same string type. DEPRECATED. -type UNodes text = Nodes text text -{-# DEPRECATED UNodes "use [UNode text] instead" #-} - -- | Type alias for a node with unqualified tag names where tag and -- text are the same string type. type UNode text = Node text text --- | DEPRECATED: Use [QNode text] instead. --- --- Type alias for nodes where qualified names are used for tags -{-# DEPRECATED QNodes "use [QNode text] instead" #-} -type QNodes text = [Node (QName text) text] - -- | Type alias for a node where qualified names are used for tags type QNode text = Node (QName text) text --- | DEPRECATED: Use [NNode text] instead. --- --- Type alias for nodes where namespaced names are used for tags. -{-# DEPRECATED NNodes "use [NNode text] instead" #-} -type NNodes text = [Node (NName text) text] - -- | Type alias for a node where namespaced names are used for tags type NNode text = Node (NName text) text @@ -328,65 +274,9 @@ ParseOptions tag text -- ^ Parse options -> ByteString -- ^ Input text (a strict ByteString) -> Either XMLParseError (Node tag text) -parse' opts doc = unsafePerformIO $ runParse where - runParse = do - let enc = overrideEncoding opts - let mEntityDecoder = entityDecoder opts - - parser <- newParser enc - - -- We maintain the invariant that the stack always has one element, - -- whose only child at the end of parsing is the root of the actual tree. - let emptyString = gxFromString "" - stack <- newIORef [Element emptyString [] []] - - case mEntityDecoder of - Just deco -> setEntityDecoder parser deco $ \_ txt -> do - modifyIORef stack (text txt) - Nothing -> return () - - setStartElementHandler parser $ \_ cName cAttrs -> do - name <- textFromCString cName - attrs <- forM cAttrs $ \(cAttrName,cAttrValue) -> do - attrName <- textFromCString cAttrName - attrValue <- textFromCString cAttrValue - return (attrName, attrValue) - modifyIORef stack (start name attrs) - return True - setEndElementHandler parser $ \_ _ -> do - modifyIORef stack end - return True - setCharacterDataHandler parser $ \_ cText -> do - txt <- gxFromCStringLen cText - modifyIORef stack (text txt) - return True - mError <- IO.parse' parser doc - case mError of - Just err -> return $ Left err - 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 - text _ [] = impossible - end (cur:parent:rest) = - let node = modifyChildren reverse cur in - modifyChildren (node:) parent : rest - end _ = impossible - impossible = error "parse' impossible" - - --- | DEPRECATED: use 'parse' instead. --- --- Strictly parse XML to tree. Returns error message or valid parsed tree. -parseTree' :: (GenericXMLString tag, GenericXMLString text) => - Maybe Encoding -- ^ Optional encoding override - -> ByteString -- ^ Input text (a strict ByteString) - -> Either XMLParseError (Node tag text) -{-# DEPRECATED parseTree' "use Text.XML.Expat.parse' instead" #-} -parseTree' enc = parse' (ParseOptions enc Nothing) - +parse' opts doc = case parse opts (L.fromChunks [doc]) of + (xml, Nothing) -> Right xml + (_, Just err) -> Left err -- | A lower level function that lazily converts a SAX stream into a tree structure. saxToTree :: GenericXMLString tag => @@ -460,19 +350,6 @@ -> ItemM l (NodeG l tag text) parseG opts = saxToTreeG . SAX.parseG opts --- | DEPREACTED: Use 'parse' instead. --- --- Lazily parse XML to tree. Note that forcing the XMLParseError return value --- will force the entire parse. Therefore, to ensure lazy operation, don't --- check the error status until you have processed the tree. -parseTree :: (GenericXMLString tag, GenericXMLString text) => - Maybe Encoding -- ^ Optional encoding override - -> L.ByteString -- ^ Input text (a lazy ByteString) - -> (Node tag text, Maybe XMLParseError) -{-# DEPRECATED parseTree "use Text.XML.Expat.Tree.parse instead" #-} -parseTree mEnc = parse (ParseOptions mEnc Nothing) - - -- | Lazily parse XML to tree. In the event of an error, throw 'XMLParseException'. -- -- @parseThrowing@ can throw an exception from pure code, which is generally a bad @@ -485,14 +362,3 @@ -> L.ByteString -- ^ Input text (a lazy ByteString) -> Node tag text parseThrowing opts bs = fst $ saxToTree $ SAX.parseThrowing opts bs - - --- | DEPRECATED: Use 'parseThrowing' instead. --- --- Lazily parse XML to tree. In the event of an error, throw 'XMLParseException'. -parseTreeThrowing :: (GenericXMLString tag, GenericXMLString text) => - Maybe Encoding -- ^ Optional encoding override - -> L.ByteString -- ^ Input text (a lazy ByteString) - -> Node tag text -{-# DEPRECATED parseTreeThrowing "use Text.XML.Expat.Tree.parseThrowing instead" #-} -parseTreeThrowing mEnc = parseThrowing (ParseOptions mEnc Nothing) 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.19.10 +Version: 0.20.1 Synopsis: XML parser/formatter based on expat Description: This package provides a general purpose Haskell XML library using Expat to @@ -23,8 +23,9 @@ If you want to do interactive I\/O, an obvious option is to use lazy parsing with one of the lazy I\/O functions such as hGetContents. However, this can be problematic in some applications because it doesn't handle I\/O errors properly - and can give no guarantee of timely resource cleanup. In these cases, chunked - I\/O is a better approach: Take a look at the /hexpat-enumerator/ package. + and can give no guarantee of timely resource cleanup. Because of the generalized + list, Hexpat is designed to allow for chunked I/O, but as of this writing I haven't + done a nice integration with enumerator and friends. . /IO/ is filed under /Internal/ because it's low-level and most users won't want it. The other /Internal/ modules are re-exported by /Annotated/, /Tree/ and /Extended/, @@ -33,14 +34,6 @@ Credits to Iavor Diatchki and the @xml@ (XML.Light) package for /Proc/ and /Cursor/. Thanks to the many contributors. . - BOUND VS. UNBOUND THREADS: GHC (at least versions 6.12.X) will spawn threads - if you call a safe FFI callback from an unbound thread. This can get out of - control in a busy application. To avoid this, from version 0.19.1 we now delegate - processing to a single worker thread if the calling thread is not bound. - This essentially means that hexpat currently won't exploit multicores very well. - It also means that hexpat may be more efficient on threads spawned with forkOS - (to give you a bound thread) rather than forkIO. - . 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; 0.15.1 Fix broken Annotated parse; 0.16 switch from mtl to transformers; 0.17 fix mapNodeContainer & rename some things.; @@ -52,7 +45,9 @@ which broke entity parsing; 0.19.4 bump version constraint for text; 0.19.5 bump text to < 0.12 and fix text-0.10.0.1 breakage; 0.19.6 dependency breakage with List; 0.19.7 ghc-7.2.1 compatibility; 0.19.8 fix space leak on lazy parse under ghc-7.2.1; - 0.19.9 fix formatting of > character + improve performance; 0.9.10 ghc-7.4.x compatibility. + 0.19.9 fix formatting of > character + improve performance; 0.19.10 ghc-7.4.x compatibility; + 0.20.1 fix an unfortunate crash when used in parallel processing and greatly improve + performance. Category: XML License: BSD3 License-File: LICENSE @@ -95,6 +90,8 @@ test/hexpat-leak/Parse.hs, test/hexpat-leak/run.sh, test/hexpat-leak/build.sh + test/readRoads.hs, + test/ROADS.xml, cbits/amigaconfig.h, cbits/asciitab.h, cbits/expat.h, @@ -132,11 +129,7 @@ Text.XML.Expat.Cursor, Text.XML.Expat.Extended, Text.XML.Expat.Format, - Text.XML.Expat.IO, - Text.XML.Expat.Namespaced, - Text.XML.Expat.NodeClass, Text.XML.Expat.Proc, - Text.XML.Expat.Qualified, Text.XML.Expat.SAX, Text.XML.Expat.Tree, Text.XML.Expat.Internal.DocumentClass, @@ -152,6 +145,7 @@ cbits/xmlrole.c, cbits/xmltok.c, cbits/xmltok_impl.c, - cbits/xmltok_ns.c + cbits/xmltok_ns.c, + Text/XML/Expat/Internal/Glue.c cc-options: -DHAVE_MEMMOVE -DXML_NS -DXML_DTD diff --git a/test/ROADS.xml b/test/ROADS.xml new file mode 100644 --- /dev/null +++ b/test/ROADS.xml @@ -0,0 +1,1008 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/test/readRoads.hs b/test/readRoads.hs new file mode 100644 --- /dev/null +++ b/test/readRoads.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE OverloadedStrings #-} +import Text.XML.Expat.Tree +import Control.Monad +import Data.Text (Text) +import qualified Data.Text as T +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as L +import Data.Maybe + + +-- Reads the contents of ROADS.xml from stdin +main :: IO () +main = do + bs <- L.getContents + let Element _ _ chs = parseThrowing defaultParseOptions bs :: UNode Text + forM_ chs $ \ch -> do + case ch of + elt@(Element "shape" _ _) -> do + putStrLn $ T.unpack $ fromMaybe "" $ getAttribute elt "FULL_NAME" + _ -> return () diff --git a/test/suite/Text/XML/Expat/ParseFormat.hs b/test/suite/Text/XML/Expat/ParseFormat.hs --- a/test/suite/Text/XML/Expat/ParseFormat.hs +++ b/test/suite/Text/XML/Expat/ParseFormat.hs @@ -173,7 +173,7 @@ sbDoc = normalizeText $ fromElement (getRoot $ pfDoc pf) assertEqual "parse match" sbDoc (root :: Tree.UNode Text) let sb = fromMaybe (pfXML pf) (impl `lookup` pfOutXML pf) - bs = formatTree' root + bs = format' root assertEqual "format match" sb bs ] Annotated -> [ @@ -185,7 +185,7 @@ sbDoc = normalizeText $ fromElement (getRoot $ pfDoc pf) assertEqual "parse match" sbDoc (root :: Annotated.UNode () Text) let sb = fromMaybe (pfXML pf) (impl `lookup` pfOutXML pf) - bs = formatTree' root + bs = format' root assertEqual "format match" sb bs ] Extended -> [ diff --git a/test/suite/Text/XML/Expat/UnitTests.hs b/test/suite/Text/XML/Expat/UnitTests.hs --- a/test/suite/Text/XML/Expat/UnitTests.hs +++ b/test/suite/Text/XML/Expat/UnitTests.hs @@ -2,12 +2,14 @@ import Text.XML.Expat.Tree hiding (parse) import qualified Text.XML.Expat.Tree as Tree -import Text.XML.Expat.IO hiding (parse) -import qualified Text.XML.Expat.IO as IO +import Text.XML.Expat.SAX (SAXEvent(..)) +import qualified Text.XML.Expat.SAX as SAX import Text.XML.Expat.Cursor import Text.XML.Expat.Format -import Text.XML.Expat.Qualified +import Text.XML.Expat.Extended (LDocument) +import qualified Text.XML.Expat.Extended as Extended import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as C import qualified Data.ByteString.Lazy.Char8 as LC import qualified Data.ByteString.Lazy as L import qualified Data.Text as T @@ -16,8 +18,10 @@ import Data.ByteString.Internal (c2w, w2c) import Data.Char import Data.Maybe +import Data.Monoid import Data.IORef import Control.Applicative +import Control.Arrow (first) import Control.Exception as E import Control.Monad import Control.DeepSeq @@ -98,30 +102,6 @@ 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 - IO.parse parser lazy - l <- reverse <$> readIORef ref - assertEqual "parse" - ["start open","start test1","end test1","start hello","end hello","end open"] - l - - test_entities1 = do assertEqual "parse error" merr Nothing assertEqual "entity substitution" (Text "foo") c @@ -240,6 +220,63 @@ data ParseFormatTest = ParseFormatTest { } +test_xmlDecl1 :: IO () +test_xmlDecl1 = do + assertEqual "plain" [XMLDeclaration "1.0" Nothing Nothing,StartElement "hello" [],EndElement "hello"] + (SAX.parse defaultParseOptions (LC.pack "") :: [SAXEvent String String]) + assertEqual "withEnc" [XMLDeclaration "1.0" (Just "UTF-8") Nothing,StartElement "hello" [],EndElement "hello"] + (SAX.parse defaultParseOptions (LC.pack "") :: [SAXEvent String String]) + assertEqual "SA0" [XMLDeclaration "1.0" Nothing (Just False),StartElement "hello" [],EndElement "hello"] + (SAX.parse defaultParseOptions (LC.pack "") :: [SAXEvent String String]) + assertEqual "SA1" [XMLDeclaration "1.0" Nothing (Just True),StartElement "hello" [],EndElement "hello"] + (SAX.parse defaultParseOptions (LC.pack "") :: [SAXEvent String String]) + assertEqual "SA0enc" [XMLDeclaration "1.0" (Just "UTF-8") (Just False),StartElement "hello" [],EndElement "hello"] + (SAX.parse defaultParseOptions (LC.pack "") :: [SAXEvent String String]) + assertEqual "SA1enc" [XMLDeclaration "1.0" (Just "UTF-8") (Just True),StartElement "hello" [],EndElement "hello"] + (SAX.parse defaultParseOptions (LC.pack "") :: [SAXEvent String String]) + +test_various :: IO () +test_various = + assertEqual "var1" [ + StartElement "test" [], + StartElement "sample" [("id","5")], + CharacterData "This \"text with quotations\" should be escaped.", + EndElement "sample", + StartElement "mytest" [], + CharacterData "//", + StartCData, + CharacterData "This \"text with quotations\" should not be escaped.//", + EndCData, + EndElement "mytest", + ProcessingInstruction "php" "somecode(); ", + Comment " this is a comment ", + EndElement "test" + ] + (SAX.parse defaultParseOptions (LC.pack variousText) :: [SAXEvent String String]) + +variousText = + ""++ + "This \"text with quotations\" should be escaped."++ + ""++ + "//"++ + ""++ + ""++ + ""++ + "" + +quotationOut = + "This "text with quotations" should be escaped."++ + "//"++ + "" + +test_quotation = + assertEqual "quotation" + (quotationOut, Nothing) + $ first (C.unpack . mconcat . LC.toChunks . formatDocument) + $ (Extended.parse defaultParseOptions (LC.pack variousText) :: (LDocument String String, Maybe XMLParseError)) + tests = hUnitTestToTests $ TestList [ t' ("String", @@ -276,12 +313,14 @@ TestLabel "error2" $ TestCase $ test_error2, TestLabel "error3" $ TestCase $ test_error3, TestLabel "error4" $ TestCase $ test_error4, - TestLabel "parse" $ TestCase $ test_parse, TestLabel "entities1" $ TestCase $ test_entities1, TestLabel "entities2" $ TestCase $ test_entities2, TestLabel "textContent" $ TestCase $ test_textContent, TestLabel "indent" $ TestCase $ test_indent, - TestLabel "setAttribute" $ TestCase $ test_setAttribute + TestLabel "setAttribute" $ TestCase $ test_setAttribute, + TestLabel "xmlDecl1" $ TestCase $ test_xmlDecl1, + TestLabel "various" $ TestCase $ test_various, + TestLabel "quotation" $ TestCase $ test_quotation ] where