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 @@ -9,26 +9,12 @@ -- * Tree structure Node, NodeG(..), - Attributes, -- re-export from NodeClass UNode, - UAttributes, -- re-export from NodeClass LNode, ULNode, - textContent, - isElement, - isNamed, - isText, - getName, - getAttributes, - getAttribute, - getChildren, - modifyName, - modifyAttributes, - setAttribute, - deleteAttribute, - alterAttribute, - modifyChildren, - mapAllTags, + + -- * Generic node manipulation + module Text.XML.Expat.NodeClass, -- * Annotation-specific unannotate, diff --git a/Text/XML/Expat/Cursor.hs b/Text/XML/Expat/Cursor.hs --- a/Text/XML/Expat/Cursor.hs +++ b/Text/XML/Expat/Cursor.hs @@ -93,7 +93,6 @@ ) where import Text.XML.Expat.Tree -import Text.XML.Expat.NodeClass import Data.Maybe(isNothing) import Data.Monoid import Control.Monad.Identity 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 @@ -115,19 +115,7 @@ | otherwise = mzero where singleton = return - -concatL :: List l => l (l a) -> l a -concatL l1 = joinL $ do - li1 <- runList l1 - return $ case li1 of - Nil -> mzero - Cons l2 l1' -> - let concat2L l2 = joinL $ do - li2 <- runList l2 - return $ case li2 of - Nil -> concatL l1' - Cons elt l2' -> cons elt $ concat2L l2' - in concat2L l2 + concatL = join -- | Format SAX events with no header - lazy variant that returns lazy ByteString. formatSAX :: (GenericXMLString tag, GenericXMLString text) => 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 @@ -1,4 +1,4 @@ -{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-} -- hexpat, a Haskell wrapper for expat -- Copyright (C) 2008 Evan Martin @@ -12,14 +12,20 @@ -- -- (2) Set up callbacks on the parser: 'setStartElementHandler', etc. -- --- (3) Feed data into the parser: 'parse', 'parse'' or 'parseChunk'. +-- (3) Feed data into the parser: 'parse', 'parse'' or 'parseChunk'. Some of +-- these functions must be wrapped in 'withParser'. module Text.XML.Expat.IO ( -- ** Parser Setup Parser, newParser, -- ** Parsing - parse, parse', parseChunk, Encoding(..), XMLParseError(..), + parse, parse', + withParser, + ParserPtr, Parser_struct, + parseChunk, + Encoding(..), + XMLParseError(..), getParseLocation, XMLParseLocation(..), @@ -38,10 +44,6 @@ -- ** Lower-level interface parseExternalEntityReference, - unsafeParseChunk, - withHandlers, - unsafeSetHandlers, - unsafeReleaseHandlers, ExpatHandlers, -- ** Helpers @@ -59,9 +61,10 @@ -- |Opaque parser type. -type ParserPtr = Ptr () +data Parser_struct +type ParserPtr = Ptr Parser_struct data Parser = Parser - { _parserObj :: ForeignPtr () + { _parserObj :: ForeignPtr Parser_struct , _startElementHandler :: IORef CStartElementHandler , _endElementHandler :: IORef CEndElementHandler , _cdataHandler :: IORef CCharacterDataHandler @@ -72,9 +75,6 @@ instance Show Parser where showsPrec _ (Parser fp _ _ _ _ _) = showsPrec 0 fp -withParser :: Parser -> (ParserPtr -> IO a) -> IO a -withParser (Parser fp _ _ _ _ _) = withForeignPtr fp - -- |Encoding types available for the document encoding. data Encoding = ASCII | UTF8 | UTF16 | ISO88591 encodingToString :: Encoding -> String @@ -90,10 +90,10 @@ parserCreate :: Maybe Encoding -> IO (ParserPtr) parserCreate a1 = - withOptEncoding a1 $ \a1' -> - parserCreate'_ a1' >>= \res -> - let {res' = id res} in - return (res') + withOptEncoding a1 $ \a1' -> do + pp <- parserCreate'_ a1' + xmlSetUserData pp pp + return pp -- | Create a 'Parser'. newParser :: Maybe Encoding -> IO Parser @@ -106,7 +106,6 @@ extH <- newIORef Nothing skipH <- newIORef Nothing - return $ Parser fptr nullStartH nullEndH nullCharH extH skipH setUseForeignDTD :: Parser -> Bool -> IO () @@ -127,36 +126,27 @@ -- |@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 = withHandlers parser $ do +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 parser - where - doParseChunks [] = doParseChunk parser BS.empty True - doParseChunks (c:cs) = do - ok <- doParseChunk parser c False - if ok - then doParseChunks cs - else return False + 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 = withHandlers parser $ do - ok <- doParseChunk parser bs True +parse' parser bs = withParser parser $ \pp -> do + ok <- doParseChunk pp bs True if ok then return Nothing - else Just `fmap` getError parser - --- |@parseChunk data False@ feeds /strict/ ByteString data into a --- 'Parser'. The end of the data is indicated by passing @True@ for the --- final parameter. It returns Nothing on success, or Just the parse error. -parseChunk :: Parser - -> BS.ByteString - -> Bool -- ^ True if last chunk - -> IO (Maybe XMLParseError) -parseChunk parser xml final = withHandlers parser $ unsafeParseChunk parser xml final + else Just `fmap` getError pp parseExternalEntityReference :: Parser -> CString -- ^ context @@ -164,33 +154,32 @@ -> CStringLen -- ^ text -> IO Bool parseExternalEntityReference parser context encoding (text,sz) = - withParser parser $ \p -> do + withParser parser $ \pp -> do extp <- withOptEncoding encoding $ - xmlExternalEntityParserCreate p context + xmlExternalEntityParserCreate pp context e <- doParseChunk'_ extp text (fromIntegral sz) 1 parserFree' extp return $ e == 1 --- | This variant of 'parseChunk' must either be called inside 'withHandlers' --- (safest), or between 'unsafeSetHandlers' and 'unsafeReleaseHandlers', and --- this will give you better performance than 'parseChunk' if you process --- multiple chunks inside. -unsafeParseChunk :: Parser +-- |@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) -unsafeParseChunk parser xml final = do - ok <- doParseChunk parser xml final +parseChunk pp xml final = do + ok <- doParseChunk pp xml final if ok then return Nothing - else Just `fmap` getError parser + else Just `fmap` getError pp -getError :: Parser -> IO XMLParseError -getError parser = withParser parser $ \p -> do - code <- xmlGetErrorCode p +getError :: ParserPtr -> IO XMLParseError +getError pp = do + code <- xmlGetErrorCode pp cerr <- xmlErrorString code err <- peekCString cerr - loc <- getParseLocation parser + loc <- getParseLocation pp return $ XMLParseError err loc data ExpatHandlers = ExpatHandlers @@ -200,63 +189,62 @@ (Maybe (FunPtr CExternalEntityRefHandler)) (Maybe (FunPtr CSkippedEntityHandler)) -unsafeSetHandlers :: Parser -> IO ExpatHandlers -unsafeSetHandlers parser@(Parser _ startRef endRef charRef extRef skipRef) = - do - 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) - - withParser parser $ \p -> do - xmlSetstartelementhandler p cStartH - xmlSetendelementhandler p cEndH - xmlSetcharacterdatahandler p cCharH +-- | 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 _ startRef endRef charRef extRef skipRef) pp = + do + 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) + + xmlSetstartelementhandler pp cStartH + xmlSetendelementhandler pp cEndH + xmlSetcharacterdatahandler pp cCharH maybe (return ()) - (xmlSetExternalEntityRefHandler p) + (xmlSetExternalEntityRefHandler pp) mExtH maybe (return ()) - (xmlSetSkippedEntityHandler p) + (xmlSetSkippedEntityHandler pp) mSkipH + + return $ ExpatHandlers cStartH cEndH cCharH mExtH mSkipH + + unsafeReleaseHandlers :: ExpatHandlers -> IO () + unsafeReleaseHandlers (ExpatHandlers cStartH cEndH cCharH mcExtH mcSkipH) = do + freeHaskellFunPtr cStartH + freeHaskellFunPtr cEndH + freeHaskellFunPtr cCharH + maybe (return ()) freeHaskellFunPtr mcExtH + maybe (return ()) freeHaskellFunPtr mcSkipH - return $ ExpatHandlers cStartH cEndH cCharH mExtH mSkipH -unsafeReleaseHandlers :: ExpatHandlers -> IO () -unsafeReleaseHandlers (ExpatHandlers cStartH cEndH cCharH mcExtH mcSkipH) = do - freeHaskellFunPtr cStartH - freeHaskellFunPtr cEndH - freeHaskellFunPtr cCharH - maybe (return ()) freeHaskellFunPtr mcExtH - maybe (return ()) freeHaskellFunPtr mcSkipH - --- | 'unsafeParseChunk' is required to be called inside @withHandlers@. --- Safer than using 'unsafeSetHandlers' / 'unsafeReleaseHandlers'. -withHandlers :: Parser - -> IO a -- ^ Computation where unsafeParseChunk may be used - -> IO a -withHandlers parser code = do - bracket - (unsafeSetHandlers parser) - unsafeReleaseHandlers - (\_ -> code) - -- |Obtain C value from Haskell 'Bool'. -- cFromBool :: Num a => Bool -> a cFromBool = fromBool -doParseChunk :: Parser -> BS.ByteString -> Bool -> IO (Bool) +doParseChunk :: ParserPtr -> BS.ByteString -> Bool -> IO (Bool) doParseChunk a1 a2 a3 = - withParser a1 $ \a1' -> withBStringLen a2 $ \(a2'1, a2'2) -> let {a3' = cFromBool a3} in - doParseChunk'_ a1' a2'1 a2'2 a3' >>= \res -> + doParseChunk'_ a1 a2'1 a2'2 a3' >>= \res -> let {res' = unStatus res} in return (res') @@ -278,12 +266,12 @@ instance NFData XMLParseLocation where rnf (XMLParseLocation lin col ind cou) = rnf (lin, col, ind, cou) -getParseLocation :: Parser -> IO XMLParseLocation -getParseLocation parser = withParser parser $ \p -> do - line <- xmlGetCurrentLineNumber p - col <- xmlGetCurrentColumnNumber p - index <- xmlGetCurrentByteIndex p - count <- xmlGetCurrentByteCount p +getParseLocation :: ParserPtr -> IO XMLParseLocation +getParseLocation pp = do + line <- xmlGetCurrentLineNumber pp + col <- xmlGetCurrentColumnNumber pp + index <- xmlGetCurrentByteIndex pp + count <- xmlGetCurrentByteCount pp return $ XMLParseLocation { xmlLineNumber = fromIntegral line, xmlColumnNumber = fromIntegral col, @@ -294,18 +282,18 @@ -- | The type of the \"element started\" callback. The first parameter is the -- element name; the second are the (attribute, value) pairs. Return True to -- continue parsing as normal, or False to terminate the parse. -type StartElementHandler = CString -> [(CString, CString)] -> IO Bool +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 = CString -> IO Bool +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 = CStringLen -> IO Bool +type CharacterDataHandler = ParserPtr -> CStringLen -> IO Bool -- | The type of the \"external entity reference\" callback. See the expat -- documentation. @@ -323,11 +311,12 @@ -- -- 2. An internal entity reference is read, but not expanded, because -- @XML_SetDefaultHandler@ has been called. -type SkippedEntityHandler = CString -- entityName - -> Int -- is a parameter entity? +type SkippedEntityHandler = ParserPtr + -> CString -- entityName + -> Int -- is a parameter entity? -> IO Bool -type CStartElementHandler = Ptr () -> CString -> Ptr CString -> IO () +type CStartElementHandler = ParserPtr -> CString -> Ptr CString -> IO () nullCStartElementHandler :: CStartElementHandler nullCStartElementHandler _ _ _ = return () @@ -339,17 +328,17 @@ wrapStartElementHandler :: Parser -> StartElementHandler -> CStartElementHandler wrapStartElementHandler parser handler = h where - h _ cname cattrs = do + h pp cname cattrs = do cattrlist <- peekArray0 nullPtr cattrs - stillRunning <- handler cname (pairwise cattrlist) - unless stillRunning $ stopParser parser + 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 = Ptr () -> CString -> IO () +type CEndElementHandler = ParserPtr -> CString -> IO () nullCEndElementHandler :: CEndElementHandler nullCEndElementHandler _ _ = return () @@ -360,16 +349,16 @@ wrapEndElementHandler :: Parser -> EndElementHandler -> CEndElementHandler wrapEndElementHandler parser handler = h where - h _ cname = do - stillRunning <- handler cname - unless stillRunning $ stopParser parser + 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 = Ptr () -> CString -> CInt -> IO () +type CCharacterDataHandler = ParserPtr -> CString -> CInt -> IO () nullCCharacterDataHandler :: CCharacterDataHandler nullCCharacterDataHandler _ _ _ = return () @@ -380,9 +369,9 @@ wrapCharacterDataHandler :: Parser -> CharacterDataHandler -> CCharacterDataHandler wrapCharacterDataHandler parser handler = h where - h _ cdata len = do - stillRunning <- handler (cdata, fromIntegral len) - unless stillRunning $ stopParser parser + 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 () @@ -393,26 +382,29 @@ pairwise (x1:x2:xs) = (x1,x2) : pairwise xs pairwise _ = [] -stopParser :: Parser -> IO () -stopParser parser = withParser parser $ \p -> xmlStopParser p 0 +stopp :: Parser -> IO () +stopp parser = withParser parser $ \p -> xmlStopParser p 0 ------------------------------------------------------------------------------ -- C imports foreign import ccall unsafe "XML_ParserCreate" - parserCreate'_ :: ((Ptr CChar) -> (IO (Ptr ()))) + parserCreate'_ :: Ptr CChar -> IO ParserPtr + +foreign import ccall unsafe "XML_SetUserData" + xmlSetUserData :: ParserPtr -> ParserPtr -> IO () foreign import ccall unsafe "XML_SetStartElementHandler" - xmlSetstartelementhandler :: ((Ptr ()) -> ((FunPtr ((Ptr ()) -> ((Ptr CChar) -> ((Ptr (Ptr CChar)) -> (IO ()))))) -> (IO ()))) + xmlSetstartelementhandler :: ParserPtr -> ((FunPtr (ParserPtr -> ((Ptr CChar) -> ((Ptr (Ptr CChar)) -> (IO ())))) -> (IO ()))) foreign import ccall unsafe "XML_SetEndElementHandler" - xmlSetendelementhandler :: ((Ptr ()) -> ((FunPtr ((Ptr ()) -> ((Ptr CChar) -> (IO ())))) -> (IO ()))) + xmlSetendelementhandler :: ParserPtr -> ((FunPtr (ParserPtr -> ((Ptr CChar) -> (IO ()))) -> (IO ()))) foreign import ccall unsafe "XML_SetCharacterDataHandler" - xmlSetcharacterdatahandler :: ((Ptr ()) -> ((FunPtr ((Ptr ()) -> ((Ptr CChar) -> (CInt -> (IO ()))))) -> (IO ()))) + xmlSetcharacterdatahandler :: ParserPtr -> ((FunPtr (ParserPtr -> ((Ptr CChar) -> (CInt -> (IO ())))) -> (IO ()))) foreign import ccall safe "XML_Parse" - doParseChunk'_ :: ((Ptr ()) -> ((Ptr CChar) -> (CInt -> (CInt -> (IO CInt))))) + doParseChunk'_ :: ParserPtr -> ((Ptr CChar) -> (CInt -> (CInt -> (IO CInt)))) foreign import ccall unsafe "XML_UseForeignDTD" xmlUseForeignDTD :: ParserPtr -- ^ parser @@ -452,9 +444,9 @@ -> CString -- ^ encoding -> IO ParserPtr -type CSkippedEntityHandler = Ptr () -- user data pointer - -> CString -- entity name - -> CInt -- is a parameter entity? +type CSkippedEntityHandler = ParserPtr -- user data pointer + -> CString -- entity name + -> CInt -- is a parameter entity? -> IO () foreign import ccall safe "wrapper" @@ -469,7 +461,7 @@ where h _ context base systemID publicID = do stillRunning <- handler parser context base systemID publicID - unless stillRunning $ stopParser parser + unless stillRunning $ stopp parser wrapSkippedEntityHandler :: Parser @@ -477,9 +469,9 @@ -> CSkippedEntityHandler wrapSkippedEntityHandler parser handler = h where - h _ entityName i = do - stillRunning <- handler entityName (fromIntegral i) - unless stillRunning $ stopParser parser + h pp entityName i = do + stillRunning <- handler pp entityName (fromIntegral i) + unless stillRunning $ stopp parser setExternalEntityRefHandler :: Parser -> ExternalEntityRefHandler -> IO () diff --git a/Text/XML/Expat/Namespaced.hs b/Text/XML/Expat/Namespaced.hs --- a/Text/XML/Expat/Namespaced.hs +++ b/Text/XML/Expat/Namespaced.hs @@ -13,7 +13,6 @@ ) where import Text.XML.Expat.Tree -import Text.XML.Expat.NodeClass import Text.XML.Expat.Qualified import Control.Parallel.Strategies import qualified Data.Map as M diff --git a/Text/XML/Expat/Qualified.hs b/Text/XML/Expat/Qualified.hs --- a/Text/XML/Expat/Qualified.hs +++ b/Text/XML/Expat/Qualified.hs @@ -20,7 +20,7 @@ fromQualified ) where -import Text.XML.Expat.NodeClass +import Text.XML.Expat.NodeClass () import Text.XML.Expat.Tree import Control.Parallel.Strategies import Data.Monoid 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 @@ -157,8 +157,8 @@ setSkippedEntityHandler parser skip where - skip _ 1 = return False - skip entityName 0 = do + skip _ _ 1 = return False + skip _ entityName 0 = do en <- textFromCString entityName let mbt = decoder en maybe (return False) @@ -166,7 +166,7 @@ modifyIORef queueRef (CharacterData t:) return True) mbt - skip _ _ = undefined + skip _ _ _ = undefined eh p ctx _ systemID publicID = if systemID == nullPtr && publicID == nullPtr @@ -186,17 +186,17 @@ setSkippedEntityHandler parser skip where - skip _ 1 = return False - skip entityName 0 = do + skip _ _ 1 = return False + skip pp entityName 0 = do en <- textFromCString entityName let mbt = decoder en maybe (return False) (\t -> do - loc <- getParseLocation parser + loc <- getParseLocation pp modifyIORef queueRef ((CharacterData t,loc):) return True) mbt - skip _ _ = undefined + skip _ _ _ = undefined eh p ctx _ systemID publicID = if systemID == nullPtr && publicID == nullPtr @@ -222,7 +222,7 @@ (setEntityDecoder parser queueRef) mEntityDecoder - setStartElementHandler parser $ \cName cAttrs -> do + setStartElementHandler parser $ \_ cName cAttrs -> do name <- textFromCString cName attrs <- forM cAttrs $ \(cAttrName,cAttrValue) -> do attrName <- textFromCString cAttrName @@ -231,25 +231,25 @@ modifyIORef queueRef (StartElement name attrs:) return True - setEndElementHandler parser $ \cName -> do + setEndElementHandler parser $ \_ cName -> do name <- textFromCString cName modifyIORef queueRef (EndElement name:) return True - setCharacterDataHandler parser $ \cText -> do + setCharacterDataHandler parser $ \_ cText -> do txt <- gxFromCStringLen cText modifyIORef queueRef (CharacterData txt:) return True let runParser inp = unsafeInterleaveIO $ do - rema <- case inp of + rema <- withParser parser $ \pp -> case inp of (c:cs) -> do - mError <- parseChunk parser c False + mError <- parseChunk pp c False case mError of Just err -> return [FailDocument err] Nothing -> runParser cs [] -> do - mError <- parseChunk parser B.empty True + mError <- parseChunk pp B.empty True case mError of Just err -> return [FailDocument err] Nothing -> return [] @@ -297,38 +297,39 @@ (setEntityDecoderLoc parser queueRef) mEntityDecoder - setStartElementHandler parser $ \cName cAttrs -> do + 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 parser + loc <- getParseLocation pp modifyIORef queueRef ((StartElement name attrs,loc):) return True - setEndElementHandler parser $ \cName -> do + setEndElementHandler parser $ \pp cName -> do name <- textFromCString cName - loc <- getParseLocation parser + loc <- getParseLocation pp modifyIORef queueRef ((EndElement name, loc):) return True - setCharacterDataHandler parser $ \cText -> do + setCharacterDataHandler parser $ \pp cText -> do txt <- gxFromCStringLen cText - loc <- getParseLocation parser + loc <- getParseLocation pp 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 [] - rema <- case mError of - Just err -> do - loc <- getParseLocation parser - return [(FailDocument err, loc)] - Nothing -> runParser cs + 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 @@ -96,25 +96,11 @@ -- * Tree structure Node, NodeG(..), - Attributes, UNode, - UAttributes, - textContent, - isElement, - isNamed, - isText, - getName, - getAttributes, - getAttribute, - getChildren, - modifyName, - modifyAttributes, - setAttribute, - deleteAttribute, - alterAttribute, - modifyChildren, - mapAllTags, + -- * Generic node manipulation + module Text.XML.Expat.NodeClass, + -- * Parse to tree ParserOptions(..), defaultParserOptions, @@ -302,8 +288,8 @@ text str (cur:rest) = modifyChildren (Text str:) cur : rest text _ [] = undefined - skip _ 1 = return False - skip entityName 0 = do + skip _ _ 1 = return False + skip _ entityName 0 = do en <- textFromCString entityName let mbt = decoder en maybe (return False) @@ -311,7 +297,7 @@ modifyIORef queueRef $ text t return True) mbt - skip _ _ = undefined + skip _ _ _ = undefined eh p ctx _ systemID publicID = if systemID == nullPtr && publicID == nullPtr @@ -341,7 +327,7 @@ (setEntityDecoder parser stack) mEntityDecoder - setStartElementHandler parser $ \cName cAttrs -> do + setStartElementHandler parser $ \_ cName cAttrs -> do name <- textFromCString cName attrs <- forM cAttrs $ \(cAttrName,cAttrValue) -> do attrName <- textFromCString cAttrName @@ -349,10 +335,10 @@ return (attrName, attrValue) modifyIORef stack (start name attrs) return True - setEndElementHandler parser $ \_ -> do + setEndElementHandler parser $ \_ _ -> do modifyIORef stack end return True - setCharacterDataHandler parser $ \cText -> do + setCharacterDataHandler parser $ \_ cText -> do txt <- gxFromCStringLen cText modifyIORef stack (text txt) return True 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.14 +Version: 0.15 Synopsis: wrapper for expat, the fast XML parser Description: This package provides a general purpose Haskell XML library using Expat to @@ -38,6 +38,9 @@ @cabal install hexpat --extra-lib-dirs="C:\\Program Files\\Expat 2.0.1\\Bin" --extra-include-dirs="C:\\Program Files\\Expat 2.0.1\\Source\\Lib"@ . 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. Category: XML License: BSD3 License-File: LICENSE 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 @@ -105,11 +105,11 @@ toByteString "1>"] parser <- newParser Nothing - setStartElementHandler parser $ \cname cattrs -> do + setStartElementHandler parser $ \_ cname cattrs -> do name <- peekCString cname ref <- modifyIORef ref $ \l -> ("start "++name):l return True - setEndElementHandler parser $ \cname -> do + setEndElementHandler parser $ \_ cname -> do name <- peekCString cname ref <- modifyIORef ref $ \l -> ("end "++name):l return True