diff --git a/Text/XML/LibXML/SAX.hs b/Text/XML/LibXML/SAX.hs deleted file mode 100644 --- a/Text/XML/LibXML/SAX.hs +++ /dev/null @@ -1,744 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE CPP #-} - ------------------------------------------------------------------------------ --- | --- Module: Text.XML.LibXML.SAX --- Copyright: 2010 John Millikin --- License: MIT --- --- Maintainer: jmillikin@gmail.com --- Portability: portable --- --- Bindings for the libXML2 SAX interface --- ------------------------------------------------------------------------------ - -module Text.XML.LibXML.SAX - ( - -- * Parser - Parser - , newParserIO - , newParserST - - -- ** Parser input - , parseBytes - , parseComplete - - -- * Callbacks - , Callback - , setCallback - , clearCallback - - -- ** Parse events - , parsedBeginDocument - , parsedEndDocument - , parsedBeginElement - , parsedEndElement - , parsedCharacters - , parsedReference - , parsedComment - , parsedInstruction - , parsedCDATA - , parsedWhitespace - , parsedInternalSubset - , parsedExternalSubset - - -- ** Warning and error reporting - , reportWarning - , reportError - - ) where - -import qualified Control.Exception as E -import Control.Monad (when, unless) -import qualified Control.Monad.ST as ST -import qualified Data.ByteString as B -import qualified Data.ByteString.Unsafe as BU -import Data.Char (chr, isDigit) -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import qualified Data.XML.Types as X -import Data.IORef (IORef, newIORef, readIORef, writeIORef) -import Foreign hiding (free, void) -import Foreign.C -import qualified Foreign.Concurrent as FC -import Text.ParserCombinators.ReadP ((+++)) -import qualified Text.ParserCombinators.ReadP as ReadP - -data Context = Context - --- | A 'Parser' tracks the internal state of a LibXML parser context. --- --- As LibXML is a very stateful library, parsers must operate within either --- the 'IO' or 'ST.ST' monad. Use 'newParserIO' or 'newParserST' to create --- parsers in the appropriate monad. --- --- In general, clients should prefer 'newParserST', because ST values can be --- safely computed with no side effects. -data Parser m = Parser - { parserHandle :: ForeignPtr Context - , parserErrorRef :: IORef (Maybe E.SomeException) - , parserToIO :: forall a. m a -> IO a - , parserFromIO :: forall a. IO a -> m a - } - -newParserIO :: Maybe T.Text -- ^ An optional filename or URI - -> IO (Parser IO) -newParserIO filename = E.block $ do - ref <- newIORef Nothing - - raw <- maybeWith withUTF8 filename cAllocParser - managed <- newForeignPtr_ raw - - FC.addForeignPtrFinalizer managed (cFreeParser raw) - FC.addForeignPtrFinalizer managed (freeCallbacks raw) - - return (Parser managed ref id id) - -newParserST :: Maybe T.Text -- ^ An optional filename or URI - -> ST.ST s (Parser (ST.ST s)) -newParserST filename = ST.unsafeIOToST $ do - p <- newParserIO filename - return $ p - { parserToIO = ST.unsafeSTToIO - , parserFromIO = ST.unsafeIOToST - } - -parseImpl :: Parser m -> (Ptr Context -> IO a) -> m () -parseImpl p io = parserFromIO p $ do - writeIORef (parserErrorRef p) Nothing - E.block (void (withParserIO p io)) - - threw <- readIORef (parserErrorRef p) - case threw of - Nothing -> return () - Just exc -> E.throwIO exc - -parseBytes :: Parser m -> B.ByteString -> m () -parseBytes p bytes = parseImpl p $ \h -> - BU.unsafeUseAsCStringLen bytes $ \(cstr, len) -> - cParseChunk h cstr (fromIntegral len) 0 - --- | Finish parsing any buffered data, and check that the document was --- closed correctly. --- -parseComplete :: Parser m -> m () -parseComplete p = parseImpl p (\h -> cParseChunk h nullPtr 0 1) - --- Callbacks {{{ - -freeCallbacks :: Ptr Context -> IO () -freeCallbacks ctx = do - getcb_startDocument ctx >>= freeFunPtr - getcb_endDocument ctx >>= freeFunPtr - getcb_startElementNs ctx >>= freeFunPtr - getcb_endElementNs ctx >>= freeFunPtr - getcb_characters ctx >>= freeFunPtr - getcb_reference ctx >>= freeFunPtr - getcb_comment ctx >>= freeFunPtr - getcb_processingInstruction ctx >>= freeFunPtr - getcb_cdataBlock ctx >>= freeFunPtr - getcb_ignorableWhitespace ctx >>= freeFunPtr - getcb_internalSubset ctx >>= freeFunPtr - getcb_externalSubset ctx >>= freeFunPtr - getcb_warning ctx >>= freeFunPtr - getcb_error ctx >>= freeFunPtr - -data Callback m a = Callback (Parser m -> a -> IO ()) (Parser m -> IO ()) - --- | Set a callback computation to run when a particular parse event occurs. --- The callback should return 'True' to continue parsing, or 'False' --- to abort. --- --- Alternatively, callbacks may throw an 'E.Exception' to abort parsing. The --- exception will be propagated through to the caller of 'parseBytes' or --- 'parseComplete'. -setCallback :: Parser m -> Callback m a -> a -> m () -setCallback p (Callback set _) io = parserFromIO p (set p io) - --- | Remove a callback from the parser. This might also change the parser's --- behavior, such as automatically expanding entity references when no --- 'parsedReference' callback is set. -clearCallback :: Parser m -> Callback m a -> m () -clearCallback p (Callback _ clear) = parserFromIO p (clear p) - -catchRef :: Parser m -> Ptr Context -> m Bool -> IO () -catchRef p cb_ctx io = withParserIO p $ \ctx -> - (cWantCallback ctx cb_ctx >>=) $ \want -> - when (want == 1) $ do - continue <- E.catch (E.unblock (parserToIO p io)) $ \e -> do - writeIORef (parserErrorRef p) (Just e) - return False - unless continue (cStopParser ctx) - -catchRefIO :: Parser m -> Ptr Context -> IO Bool -> IO () -catchRefIO p cb_ctx io = catchRef p cb_ctx (parserFromIO p io) - -callback :: (Parser m -> a -> IO (FunPtr b)) - -> (Ptr Context -> IO (FunPtr b)) - -> (Ptr Context -> FunPtr b -> IO ()) - -> Callback m a -callback wrap getPtr setPtr = Callback set clear where - set p io = withForeignPtr (parserHandle p) $ \ctx -> do - free ctx - wrap p io >>= setPtr ctx - clear p = withForeignPtr (parserHandle p) $ \ctx -> do - free ctx - setPtr ctx nullFunPtr - free ctx = getPtr ctx >>= freeFunPtr - --- begin document {{{ - -parsedBeginDocument :: Callback m (m Bool) -parsedBeginDocument = callback wrap_startDocument - getcb_startDocument - setcb_startDocument - -type StartDocumentSAXFunc = Ptr Context -> IO () - -wrap_startDocument :: Parser m -> m Bool -> IO (FunPtr StartDocumentSAXFunc) -wrap_startDocument p io = newcb_startDocument (\ctx -> catchRef p ctx io) - -foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_startDocument" - getcb_startDocument :: Ptr Context -> IO (FunPtr StartDocumentSAXFunc) - -foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_startDocument" - setcb_startDocument :: Ptr Context -> FunPtr StartDocumentSAXFunc -> IO () - -foreign import ccall "wrapper" - newcb_startDocument :: StartDocumentSAXFunc -> IO (FunPtr StartDocumentSAXFunc) - --- }}} - --- end document {{{ - -parsedEndDocument :: Callback m (m Bool) -parsedEndDocument = callback wrap_endDocument - getcb_endDocument - setcb_endDocument - -type EndDocumentSAXFunc = Ptr Context -> IO () - -wrap_endDocument :: Parser m -> m Bool -> IO (FunPtr EndDocumentSAXFunc) -wrap_endDocument p io = newcb_endDocument (\ctx -> catchRef p ctx io) - -foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_endDocument" - getcb_endDocument :: Ptr Context -> IO (FunPtr EndDocumentSAXFunc) - -foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_endDocument" - setcb_endDocument :: Ptr Context -> FunPtr EndDocumentSAXFunc -> IO () - -foreign import ccall "wrapper" - newcb_endDocument :: EndDocumentSAXFunc -> IO (FunPtr EndDocumentSAXFunc) - --- }}} - --- begin element {{{ - -parsedBeginElement :: Callback m (X.Name -> [(X.Name, [X.Content])] -> m Bool) -parsedBeginElement = callback wrap_beginElement - getcb_startElementNs - setcb_startElementNs - -type StartElementNsSAX2Func = (Ptr Context -> CString -> CString -> CString -> CInt -> Ptr CString -> CInt -> CInt -> Ptr CString -> IO ()) - -wrap_beginElement :: Parser m -> (X.Name -> [(X.Name, [X.Content])] -> m Bool) -> IO (FunPtr StartElementNsSAX2Func) -wrap_beginElement p io = - newcb_startElementNs $ \ctx cln cpfx cns _ _ n_attrs _ raw_attrs -> - catchRefIO p ctx $ do - refCB <- getcb_reference ctx - let hasRefCB = refCB /= nullFunPtr - - ns <- maybePeek peekUTF8 (castPtr cns) - pfx <- maybePeek peekUTF8 (castPtr cpfx) - ln <- peekUTF8 (castPtr cln) - attrs <- peekAttributes hasRefCB (castPtr raw_attrs) n_attrs - parserToIO p (io (X.Name ln ns pfx) attrs) - -foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_startElementNs" - getcb_startElementNs :: Ptr Context -> IO (FunPtr StartElementNsSAX2Func) - -foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_startElementNs" - setcb_startElementNs :: Ptr Context -> FunPtr StartElementNsSAX2Func -> IO () - -foreign import ccall "wrapper" - newcb_startElementNs :: StartElementNsSAX2Func -> IO (FunPtr StartElementNsSAX2Func) - -peekAttributes :: Bool -> Ptr CString -> CInt -> IO [(X.Name, [X.Content])] -peekAttributes hasRefCB ptr = loop 0 where - loop _ 0 = return [] - loop offset n = do - local <- peekUTF8 =<< peekElemOff ptr (offset + 0) - prefix <- maybePeek peekUTF8 =<< peekElemOff ptr (offset + 1) - ns <- maybePeek peekUTF8 =<< peekElemOff ptr (offset + 2) - - val_begin <- peekElemOff ptr (offset + 3) - val_end <- peekElemOff ptr (offset + 4) - val <- peekUTF8Len (val_begin, minusPtr val_end val_begin) - - let content = if hasRefCB - then parseAttributeContent val - else [X.ContentText val] - let attr = (X.Name local ns prefix, content) - attrs <- loop (offset + 5) (n - 1) - - return (attr:attrs) - -parseAttributeContent :: T.Text -> [X.Content] -parseAttributeContent = parse . T.unpack where - parse chars = case ReadP.readP_to_S parser chars of - (cs,_):_ -> cs - _ -> error "parseAttributeContent: no parse" - parser = ReadP.manyTill content eof - content = charRef +++ reference +++ text - charRef = do - void (ReadP.string "&#") - val <- ReadP.munch1 (isDigit) - void (ReadP.char ';') - return (X.ContentText (T.singleton (chr (read val)))) - reference = do - void (ReadP.char '&') - name <- ReadP.munch1 (/= ';') - void (ReadP.char ';') - return (X.ContentEntity (T.pack name)) - text = do - chars <- ReadP.munch1 (/= '&') - return (X.ContentText (T.pack chars)) - -#if MIN_VERSION_base(4,2,0) - eof = ReadP.eof -#else - eof = do - s <- ReadP.look - unless (null s) ReadP.pfail -#endif - --- }}} - --- end element {{{ - -parsedEndElement :: Callback m (X.Name -> m Bool) -parsedEndElement = callback wrap_endElementNs - getcb_endElementNs - setcb_endElementNs - -type EndElementNsSAX2Func = (Ptr Context -> CString -> CString -> CString -> IO ()) - -wrap_endElementNs :: Parser m -> (X.Name -> m Bool) -> IO (FunPtr EndElementNsSAX2Func) -wrap_endElementNs p io = - newcb_endElementNs $ \ctx cln cpfx cns -> - catchRefIO p ctx $ do - ns <- maybePeek peekUTF8 (castPtr cns) - prefix <- maybePeek peekUTF8 (castPtr cpfx) - local <- peekUTF8 (castPtr cln) - parserToIO p (io (X.Name local ns prefix)) - -foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_endElementNs" - getcb_endElementNs :: Ptr Context -> IO (FunPtr EndElementNsSAX2Func) - -foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_endElementNs" - setcb_endElementNs :: Ptr Context -> FunPtr EndElementNsSAX2Func -> IO () - -foreign import ccall "wrapper" - newcb_endElementNs :: EndElementNsSAX2Func -> IO (FunPtr EndElementNsSAX2Func) - --- }}} - --- characters, cdata, and whitespace {{{ - -parsedCharacters :: Callback m (T.Text -> m Bool) -parsedCharacters = callback wrap_characters - getcb_characters - setcb_characters - --- | If 'parsedCDATA' is set, it receives any text contained in CDATA --- blocks. By default, all text is received by 'parsedCharacters'. -parsedCDATA :: Callback m (T.Text -> m Bool) -parsedCDATA = callback wrap_characters - getcb_cdataBlock - setcb_cdataBlock - --- | If 'parsedWhitespace' is set, it receives any whitespace marked as --- ignorable by the document's DTD. By default, all text is received by --- 'parsedCharacters'. -parsedWhitespace :: Callback m (T.Text -> m Bool) -parsedWhitespace = callback wrap_characters - getcb_ignorableWhitespace - setcb_ignorableWhitespace - -type CharactersSAXFunc = (Ptr Context -> CString -> CInt -> IO ()) - -wrap_characters :: Parser m -> (T.Text -> m Bool) -> IO (FunPtr CharactersSAXFunc) -wrap_characters p io = - newcb_characters $ \ctx cstr clen -> - catchRefIO p ctx $ do - text <- peekUTF8Len (castPtr cstr, fromIntegral clen) - parserToIO p (io text) - -foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_characters" - getcb_characters :: Ptr Context -> IO (FunPtr CharactersSAXFunc) - -foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_cdataBlock" - getcb_cdataBlock :: Ptr Context -> IO (FunPtr CharactersSAXFunc) - -foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_ignorableWhitespace" - getcb_ignorableWhitespace :: Ptr Context -> IO (FunPtr CharactersSAXFunc) - -foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_characters" - setcb_characters :: Ptr Context -> FunPtr CharactersSAXFunc -> IO () - -foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_cdataBlock" - setcb_cdataBlock :: Ptr Context -> FunPtr CharactersSAXFunc -> IO () - -foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_ignorableWhitespace" - setcb_ignorableWhitespace :: Ptr Context -> FunPtr CharactersSAXFunc -> IO () - -foreign import ccall "wrapper" - newcb_characters :: CharactersSAXFunc -> IO (FunPtr CharactersSAXFunc) - --- }}} - --- entity reference {{{ - --- | If 'parsedReference' is set, entity references in element and attribute --- content will reported separately from text, and will not be automatically --- expanded. --- --- Use this when processing documents in passthrough mode, to preserve --- existing entity references. -parsedReference :: Callback m (T.Text -> m Bool) -parsedReference = callback wrap_reference - getcb_reference - setcb_reference - -type ReferenceSAXFunc = Ptr Context -> CString -> IO () - -wrap_reference :: Parser m -> (T.Text -> m Bool) -> IO (FunPtr ReferenceSAXFunc) -wrap_reference p io = - newcb_reference $ \ctx cstr -> - catchRefIO p ctx $ do - text <- peekUTF8 (castPtr cstr) - parserToIO p (io text) - -foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_reference" - getcb_reference :: Ptr Context -> IO (FunPtr ReferenceSAXFunc) - -foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_reference" - setcb_reference :: Ptr Context -> FunPtr ReferenceSAXFunc -> IO () - -foreign import ccall "wrapper" - newcb_reference :: ReferenceSAXFunc -> IO (FunPtr ReferenceSAXFunc) - --- }}} - --- comment {{{ - -parsedComment :: Callback m (T.Text -> m Bool) -parsedComment = callback wrap_comment - getcb_comment - setcb_comment - -type CommentSAXFunc = Ptr Context -> CString -> IO () - -wrap_comment :: Parser m -> (T.Text -> m Bool) -> IO (FunPtr CommentSAXFunc) -wrap_comment p io = - newcb_comment $ \ctx cstr -> - catchRefIO p ctx $ do - text <- peekUTF8 (castPtr cstr) - parserToIO p (io text) - -foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_comment" - getcb_comment :: Ptr Context -> IO (FunPtr CommentSAXFunc) - -foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_comment" - setcb_comment :: Ptr Context -> FunPtr CommentSAXFunc -> IO () - -foreign import ccall "wrapper" - newcb_comment :: CommentSAXFunc -> IO (FunPtr CommentSAXFunc) - --- }}} - --- processing instruction {{{ - -parsedInstruction :: Callback m (X.Instruction -> m Bool) -parsedInstruction = callback wrap_processingInstruction - getcb_processingInstruction - setcb_processingInstruction - -type ProcessingInstructionSAXFunc = Ptr Context -> CString -> CString -> IO () - -wrap_processingInstruction :: Parser m -> (X.Instruction -> m Bool) -> IO (FunPtr ProcessingInstructionSAXFunc) -wrap_processingInstruction p io = - newcb_processingInstruction $ \ctx ctarget cdata -> - catchRefIO p ctx $ do - target <- peekUTF8 (castPtr ctarget) - value <- peekUTF8 (castPtr cdata) - parserToIO p (io (X.Instruction target value)) - -foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_processingInstruction" - getcb_processingInstruction :: Ptr Context -> IO (FunPtr ProcessingInstructionSAXFunc) - -foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_processingInstruction" - setcb_processingInstruction :: Ptr Context -> FunPtr ProcessingInstructionSAXFunc -> IO () - -foreign import ccall "wrapper" - newcb_processingInstruction :: ProcessingInstructionSAXFunc -> IO (FunPtr ProcessingInstructionSAXFunc) - --- }}} - --- external subset {{{ - -parsedExternalSubset :: Callback m (T.Text -> Maybe X.ExternalID -> m Bool) -parsedExternalSubset = callback wrap_externalSubset - getcb_externalSubset - setcb_externalSubset - -type ExternalSubsetSAXFunc = Ptr Context -> CString -> CString -> CString -> IO () - -wrap_externalSubset :: Parser m -> (T.Text -> Maybe X.ExternalID -> m Bool) -> IO (FunPtr ExternalSubsetSAXFunc) -wrap_externalSubset p io = - newcb_externalSubset $ \ctx cname cpublic csystem -> - catchRefIO p ctx $ do - name <- peekUTF8 (castPtr cname) - public <- maybePeek peekUTF8 (castPtr cpublic) - system <- maybePeek peekUTF8 (castPtr csystem) - let external = case (public, system) of - (Nothing, Just s) -> Just (X.SystemID s) - (Just p', Just s) -> Just (X.PublicID p' s) - _ -> Nothing - parserToIO p (io name external) - -foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_externalSubset" - getcb_externalSubset :: Ptr Context -> IO (FunPtr ExternalSubsetSAXFunc) - -foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_externalSubset" - setcb_externalSubset :: Ptr Context -> FunPtr ExternalSubsetSAXFunc -> IO () - -foreign import ccall "wrapper" - newcb_externalSubset :: ExternalSubsetSAXFunc -> IO (FunPtr ExternalSubsetSAXFunc) - --- }}} - --- internal subset {{{ - -parsedInternalSubset :: Callback m (T.Text -> Maybe X.ExternalID -> m Bool) -parsedInternalSubset = callback wrap_internalSubset - getcb_internalSubset - setcb_internalSubset - -type InternalSubsetSAXFunc = Ptr Context -> CString -> CString -> CString -> IO () - -wrap_internalSubset :: Parser m -> (T.Text -> Maybe X.ExternalID -> m Bool) -> IO (FunPtr InternalSubsetSAXFunc) -wrap_internalSubset p io = - newcb_internalSubset $ \ctx cname cpublic csystem -> - catchRefIO p ctx $ do - name <- peekUTF8 (castPtr cname) - public <- maybePeek peekUTF8 (castPtr cpublic) - system <- maybePeek peekUTF8 (castPtr csystem) - let external = case (public, system) of - (Nothing, Just s) -> Just (X.SystemID s) - (Just p', Just s) -> Just (X.PublicID p' s) - _ -> Nothing - parserToIO p (io name external) - -foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_internalSubset" - getcb_internalSubset :: Ptr Context -> IO (FunPtr InternalSubsetSAXFunc) - -foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_internalSubset" - setcb_internalSubset :: Ptr Context -> FunPtr InternalSubsetSAXFunc -> IO () - -foreign import ccall "wrapper" - newcb_internalSubset :: InternalSubsetSAXFunc -> IO (FunPtr InternalSubsetSAXFunc) - --- }}} - --- warning and error {{{ - -reportWarning :: Callback m (T.Text -> m Bool) -reportWarning = callback wrap_FixedError - getcb_warning - setcb_warning - -reportError :: Callback m (T.Text -> m Bool) -reportError = callback wrap_FixedError - getcb_error - setcb_error - -type FixedErrorFunc = Ptr Context -> CString -> IO () - -wrap_FixedError :: Parser m -> (T.Text -> m Bool) -> IO (FunPtr FixedErrorFunc) -wrap_FixedError p io = - newcb_FixedError $ \ctx cmsg -> - catchRefIO p ctx $ do - msg <- peekUTF8 cmsg - parserToIO p (io msg) - -foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_warning" - getcb_warning :: Ptr Context -> IO (FunPtr FixedErrorFunc) - -foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_error" - getcb_error :: Ptr Context -> IO (FunPtr FixedErrorFunc) - -foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_warning" - setcb_warning :: Ptr Context -> FunPtr FixedErrorFunc -> IO () - -foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_error" - setcb_error :: Ptr Context -> FunPtr FixedErrorFunc -> IO () - -foreign import ccall "wrapper" - newcb_FixedError :: FixedErrorFunc -> IO (FunPtr FixedErrorFunc) - --- }}} - --- }}} - -withParserIO :: Parser m -> (Ptr Context -> IO a) -> IO a -withParserIO p io = withForeignPtr (parserHandle p) io - -peekUTF8 :: CString -> IO T.Text -peekUTF8 = fmap (TE.decodeUtf8) . B.packCString - -peekUTF8Len :: CStringLen -> IO T.Text -peekUTF8Len = fmap (TE.decodeUtf8) . B.packCStringLen - -withUTF8 :: T.Text -> (CString -> IO a) -> IO a -withUTF8 = BU.unsafeUseAsCString . TE.encodeUtf8 - -freeFunPtr :: FunPtr a -> IO () -freeFunPtr ptr = if ptr == nullFunPtr - then return () - else freeHaskellFunPtr ptr - -void :: Functor f => f a -> f () -void = fmap (const ()) - -foreign import ccall unsafe "hslibxml-shim.h hslibxml_alloc_parser" - cAllocParser :: CString -> IO (Ptr Context) - -foreign import ccall unsafe "hslibxml-shim.h hslibxml_free_parser" - cFreeParser :: Ptr Context -> IO () - -foreign import ccall safe "libxml/parser.h xmlParseChunk" - cParseChunk :: Ptr Context -> CString -> CInt -> CInt -> IO CInt - -foreign import ccall safe "libxml/parser.h xmlStopParser" - cStopParser :: Ptr Context -> IO () - -foreign import ccall unsafe "hslibxml-shim.h hslibxml_want_callback" - cWantCallback :: Ptr Context -> Ptr a -> IO CInt - --- Unbound callback FFI definitions {{{ - -{- - -data Entity = Entity - -data ParserInput = ParserInput - -data Enumeration = Enumeration - -data ElementContent = ElementContent - -data XmlError = XmlError - -type IsStandaloneSAXFunc = Ptr Context -> IO CInt - -type HasInternalSubsetSAXFunc = Ptr Context -> IO CInt - -type HasExternalSubsetSAXFunc = Ptr Context -> IO CInt - -type ExternalEntityLoader = CString -> CString -> Ptr Context -> IO (Ptr ParserInput) - -type GetEntitySAXFunc = Ptr Context -> CString -> IO (Ptr Entity) - -type EntityDeclSAXFunc = Ptr Context -> CString -> CInt -> CString -> CString -> CString -> IO () - -type NotationDeclSAXFunc = Ptr Context -> CString -> CString -> CString -> IO () - -type AttributeDeclSAXFunc = Ptr Context -> CString -> CString -> CInt -> CInt -> CString -> Ptr Enumeration -> IO () - -type ElementDeclSAXFunc = Ptr Context -> CString -> CInt -> Ptr ElementContent -> IO () - -type UnparsedEntityDeclSAXFunc = Ptr Context -> CString -> CString -> CString -> CString -> IO () - -type GetParameterEntitySAXFunc = Ptr Context -> CString -> IO (Ptr Entity) - -type XmlStructuredErrorFunc = Ptr Context -> Ptr XmlError -> IO () - -foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_isStandalone" - getcb_isStandalone :: Ptr Context -> IO (FunPtr IsStandaloneSAXFunc) - -foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_hasInternalSubset" - getcb_hasInternalSubset :: Ptr Context -> IO (FunPtr HasInternalSubsetSAXFunc) - -foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_hasExternalSubset" - getcb_hasExternalSubset :: Ptr Context -> IO (FunPtr HasExternalSubsetSAXFunc) - -foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_resolveEntity" - getcb_resolveEntity :: Ptr Context -> IO (FunPtr ResolveEntitySAXFunc) - -foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_getEntity" - getcb_getEntity :: Ptr Context -> IO (FunPtr GetEntitySAXFunc) - -foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_entityDecl" - getcb_entityDecl :: Ptr Context -> IO (FunPtr EntityDeclSAXFunc) - -foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_notationDecl" - getcb_notationDecl :: Ptr Context -> IO (FunPtr NotationDeclSAXFunc) - -foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_attributeDecl" - getcb_attributeDecl :: Ptr Context -> IO (FunPtr AttributeDeclSAXFunc) - -foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_elementDecl" - getcb_elementDecl :: Ptr Context -> IO (FunPtr ElementDeclSAXFunc) - -foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_unparsedEntityDecl" - getcb_unparsedEntityDecl :: Ptr Context -> IO (FunPtr UnparsedEntityDeclSAXFunc) - -foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_getParameterEntity" - getcb_getParameterEntity :: Ptr Context -> IO (FunPtr GetParameterEntitySAXFunc) - -foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_serror" - getcb_serror :: Ptr Context -> IO (FunPtr XmlStructuredErrorFunc) - -foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_isStandalone" - setcb_isStandalone :: Ptr Context -> FunPtr IsStandaloneSAXFunc -> IO () - -foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_hasInternalSubset" - setcb_hasInternalSubset :: Ptr Context -> FunPtr HasInternalSubsetSAXFunc -> IO () - -foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_hasExternalSubset" - setcb_hasExternalSubset :: Ptr Context -> FunPtr HasExternalSubsetSAXFunc -> IO () - -foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_resolveEntity" - setcb_resolveEntity :: Ptr Context -> FunPtr ResolveEntitySAXFunc -> IO () - -foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_getEntity" - setcb_getEntity :: Ptr Context -> FunPtr GetEntitySAXFunc -> IO () - -foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_entityDecl" - setcb_entityDecl :: Ptr Context -> FunPtr EntityDeclSAXFunc -> IO () - -foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_notationDecl" - setcb_notationDecl :: Ptr Context -> FunPtr NotationDeclSAXFunc -> IO () - -foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_attributeDecl" - setcb_attributeDecl :: Ptr Context -> FunPtr AttributeDeclSAXFunc -> IO () - -foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_elementDecl" - setcb_elementDecl :: Ptr Context -> FunPtr ElementDeclSAXFunc -> IO () - -foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_unparsedEntityDecl" - setcb_unparsedEntityDecl :: Ptr Context -> FunPtr UnparsedEntityDeclSAXFunc -> IO () - -foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_getParameterEntity" - setcb_getParameterEntity :: Ptr Context -> FunPtr GetParameterEntitySAXFunc -> IO () - -foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_serror" - setcb_serror :: Ptr Context -> FunPtr XmlStructuredErrorFunc -> IO () - --} - --- }}} diff --git a/cbits/hslibxml-shim.c b/cbits/hslibxml-shim.c new file mode 100644 --- /dev/null +++ b/cbits/hslibxml-shim.c @@ -0,0 +1,464 @@ +#define _GNU_SOURCE + +#include "hslibxml-shim.h" +#include +#include + +typedef struct UserData UserData; +struct UserData +{ + FixedErrorFunc warning; + FixedErrorFunc error; + xmlExternalEntityLoader resolveEntity; +}; + +static xmlParserInput * +hslibxml_entity_loader(const char *publicId, const char *systemId, xmlParserCtxt *ctx) +{ + UserData *user_data = (UserData *)ctx->_private; + if (user_data && user_data->resolveEntity) + { + return user_data->resolveEntity(publicId, systemId, ctx); + } + return NULL; +} + +xmlParserCtxt * +hslibxml_alloc_parser(const char *filename) +{ + xmlSAXHandler sax; + xmlParserCtxt *ctx; + UserData *user_data; + + static int entity_resolver_set = 0; + if (entity_resolver_set == 0) + { + entity_resolver_set = 1; + xmlSetExternalEntityLoader(hslibxml_entity_loader); + } + + user_data = calloc(1, sizeof(UserData)); + + memset(&sax, 0, sizeof(xmlSAXHandler)); + sax.initialized = XML_SAX2_MAGIC; + + ctx = xmlCreatePushParserCtxt(&sax, NULL, NULL, 0, filename); + ctx->replaceEntities = 1; + ctx->_private = user_data; + return ctx; +} + +void +hslibxml_free_parser(xmlParserCtxt *ctx) +{ + xmlFreeParserCtxt(ctx); +} + +int +hslibxml_want_callback(xmlParserCtxt *ctx, void *cb_ctx) +{ + if (ctx->replaceEntities) + { + return 1; + } + + return (ctx == cb_ctx); +} + +internalSubsetSAXFunc +hslibxml_getcb_internalSubset(xmlParserCtxt *ctx) +{ + return ctx->sax->internalSubset; +} + +isStandaloneSAXFunc +hslibxml_getcb_isStandalone(xmlParserCtxt *ctx) +{ + return ctx->sax->isStandalone; +} + +hasInternalSubsetSAXFunc +hslibxml_getcb_hasInternalSubset(xmlParserCtxt *ctx) +{ + return ctx->sax->hasInternalSubset; +} + +hasExternalSubsetSAXFunc +hslibxml_getcb_hasExternalSubset(xmlParserCtxt *ctx) +{ + return ctx->sax->hasExternalSubset; +} + +xmlExternalEntityLoader +hslibxml_getcb_resolveEntity(xmlParserCtxt *ctx) +{ + UserData *user_data = (UserData *)ctx->_private; + return user_data->resolveEntity; +} + +getEntitySAXFunc +hslibxml_getcb_getEntity(xmlParserCtxt *ctx) +{ + return ctx->sax->getEntity; +} + +entityDeclSAXFunc +hslibxml_getcb_entityDecl(xmlParserCtxt *ctx) +{ + return ctx->sax->entityDecl; +} + +notationDeclSAXFunc +hslibxml_getcb_notationDecl(xmlParserCtxt *ctx) +{ + return ctx->sax->notationDecl; +} + +attributeDeclSAXFunc +hslibxml_getcb_attributeDecl(xmlParserCtxt *ctx) +{ + return ctx->sax->attributeDecl; +} + +elementDeclSAXFunc +hslibxml_getcb_elementDecl(xmlParserCtxt *ctx) +{ + return ctx->sax->elementDecl; +} + +unparsedEntityDeclSAXFunc +hslibxml_getcb_unparsedEntityDecl(xmlParserCtxt *ctx) +{ + return ctx->sax->unparsedEntityDecl; +} + +startDocumentSAXFunc +hslibxml_getcb_startDocument(xmlParserCtxt *ctx) +{ + return ctx->sax->startDocument; +} + +endDocumentSAXFunc +hslibxml_getcb_endDocument(xmlParserCtxt *ctx) +{ + return ctx->sax->endDocument; +} + +referenceSAXFunc +hslibxml_getcb_reference(xmlParserCtxt *ctx) +{ + return ctx->sax->reference; +} + +charactersSAXFunc +hslibxml_getcb_characters(xmlParserCtxt *ctx) +{ + return ctx->sax->characters; +} + +ignorableWhitespaceSAXFunc +hslibxml_getcb_ignorableWhitespace(xmlParserCtxt *ctx) +{ + return ctx->sax->ignorableWhitespace; +} + +processingInstructionSAXFunc +hslibxml_getcb_processingInstruction(xmlParserCtxt *ctx) +{ + return ctx->sax->processingInstruction; +} + +commentSAXFunc +hslibxml_getcb_comment(xmlParserCtxt *ctx) +{ + return ctx->sax->comment; +} + +FixedErrorFunc +hslibxml_getcb_warning(xmlParserCtxt *ctx) +{ + UserData *user_data = (UserData *)ctx->_private; + return user_data->warning; +} + +FixedErrorFunc +hslibxml_getcb_error(xmlParserCtxt *ctx) +{ + UserData *user_data = (UserData *)ctx->_private; + return user_data->error; +} + +fatalErrorSAXFunc +hslibxml_getcb_fatalError(xmlParserCtxt *ctx) +{ + return ctx->sax->fatalError; +} + +getParameterEntitySAXFunc +hslibxml_getcb_getParameterEntity(xmlParserCtxt *ctx) +{ + return ctx->sax->getParameterEntity; +} + +cdataBlockSAXFunc +hslibxml_getcb_cdataBlock(xmlParserCtxt *ctx) +{ + return ctx->sax->cdataBlock; +} + +externalSubsetSAXFunc +hslibxml_getcb_externalSubset(xmlParserCtxt *ctx) +{ + return ctx->sax->externalSubset; +} + +startElementNsSAX2Func +hslibxml_getcb_startElementNs(xmlParserCtxt *ctx) +{ + return ctx->sax->startElementNs; +} + +endElementNsSAX2Func +hslibxml_getcb_endElementNs(xmlParserCtxt *ctx) +{ + return ctx->sax->endElementNs; +} + +xmlStructuredErrorFunc +hslibxml_getcb_serror(xmlParserCtxt *ctx) +{ + return ctx->sax->serror; +} + +void +hslibxml_setcb_internalSubset(xmlParserCtxt *ctx, internalSubsetSAXFunc cb) +{ + ctx->sax->internalSubset = cb; +} + +void +hslibxml_setcb_isStandalone(xmlParserCtxt *ctx, isStandaloneSAXFunc cb) +{ + ctx->sax->isStandalone = cb; +} + +void +hslibxml_setcb_hasInternalSubset(xmlParserCtxt *ctx, hasInternalSubsetSAXFunc cb) +{ + ctx->sax->hasInternalSubset = cb; +} + +void +hslibxml_setcb_hasExternalSubset(xmlParserCtxt *ctx, hasExternalSubsetSAXFunc cb) +{ + ctx->sax->hasExternalSubset = cb; +} + +void +hslibxml_setcb_resolveEntity(xmlParserCtxt *ctx, xmlExternalEntityLoader cb) +{ + UserData *user_data = (UserData *)ctx->_private; + user_data->resolveEntity = cb; +} + +void +hslibxml_setcb_getEntity(xmlParserCtxt *ctx, getEntitySAXFunc cb) +{ + ctx->sax->getEntity = cb; +} + +void +hslibxml_setcb_entityDecl(xmlParserCtxt *ctx, entityDeclSAXFunc cb) +{ + ctx->sax->entityDecl = cb; +} + +void +hslibxml_setcb_notationDecl(xmlParserCtxt *ctx, notationDeclSAXFunc cb) +{ + ctx->sax->notationDecl = cb; +} + +void +hslibxml_setcb_attributeDecl(xmlParserCtxt *ctx, attributeDeclSAXFunc cb) +{ + ctx->sax->attributeDecl = cb; +} + +void +hslibxml_setcb_elementDecl(xmlParserCtxt *ctx, elementDeclSAXFunc cb) +{ + ctx->sax->elementDecl = cb; +} + +void +hslibxml_setcb_unparsedEntityDecl(xmlParserCtxt *ctx, unparsedEntityDeclSAXFunc cb) +{ + ctx->sax->unparsedEntityDecl = cb; +} + +void +hslibxml_setcb_startDocument(xmlParserCtxt *ctx, startDocumentSAXFunc cb) +{ + ctx->sax->startDocument = cb; +} + +void +hslibxml_setcb_endDocument(xmlParserCtxt *ctx, endDocumentSAXFunc cb) +{ + ctx->sax->endDocument = cb; +} + +void +hslibxml_setcb_reference(xmlParserCtxt *ctx, referenceSAXFunc cb) +{ + ctx->sax->reference = cb; + + if (cb == NULL) + { ctx->replaceEntities = 1; } + + else + { ctx->replaceEntities = 0; } +} + +void +hslibxml_setcb_characters(xmlParserCtxt *ctx, charactersSAXFunc cb) +{ + ctx->sax->characters = cb; +} + +void +hslibxml_setcb_ignorableWhitespace(xmlParserCtxt *ctx, ignorableWhitespaceSAXFunc cb) +{ + ctx->sax->ignorableWhitespace = cb; +} + +void +hslibxml_setcb_processingInstruction(xmlParserCtxt *ctx, processingInstructionSAXFunc cb) +{ + ctx->sax->processingInstruction = cb; +} + +void +hslibxml_setcb_comment(xmlParserCtxt *ctx, commentSAXFunc cb) +{ + ctx->sax->comment = cb; +} + +static void +hslibxml_on_warning(void *data, const char *format, ...) +{ + xmlParserCtxt *ctx; + UserData *user_data; + char *msg; + va_list params; + int rc; + + ctx = (xmlParserCtxt *)data; + user_data = (UserData *)ctx->_private; + + va_start(params, format); + rc = vasprintf(&msg, format, params); + if (rc == -1) + { + /* try to get something to the user */ + user_data->warning(ctx, format); + return; + } + + user_data->warning(ctx, msg); + free(msg); +} + +static void +hslibxml_on_error(void *data, const char *format, ...) +{ + xmlParserCtxt *ctx; + UserData *user_data; + char *msg; + va_list params; + int rc; + + ctx = (xmlParserCtxt *)data; + user_data = (UserData *)ctx->_private; + + va_start(params, format); + rc = vasprintf(&msg, format, params); + if (rc == -1) + { + /* try to get something to the user */ + user_data->error(ctx, format); + return; + } + + user_data->error(ctx, msg); + free(msg); +} + +void +hslibxml_setcb_warning(xmlParserCtxt *ctx, FixedErrorFunc cb) +{ + UserData *user_data = (UserData *)ctx->_private; + if (cb == NULL) + { ctx->sax->warning = NULL; } + + else + { ctx->sax->warning = hslibxml_on_warning; } + + user_data->warning = cb; +} + +void +hslibxml_setcb_error(xmlParserCtxt *ctx, FixedErrorFunc cb) +{ + UserData *user_data = (UserData *)ctx->_private; + if (cb == NULL) + { ctx->sax->error = NULL; } + + else + { ctx->sax->error = hslibxml_on_error; } + + user_data->error = cb; +} + +void +hslibxml_setcb_fatalError(xmlParserCtxt *ctx, fatalErrorSAXFunc cb) +{ + ctx->sax->fatalError = cb; +} + +void +hslibxml_setcb_getParameterEntity(xmlParserCtxt *ctx, getParameterEntitySAXFunc cb) +{ + ctx->sax->getParameterEntity = cb; +} + +void +hslibxml_setcb_cdataBlock(xmlParserCtxt *ctx, cdataBlockSAXFunc cb) +{ + ctx->sax->cdataBlock = cb; +} + +void +hslibxml_setcb_externalSubset(xmlParserCtxt *ctx, externalSubsetSAXFunc cb) +{ + ctx->sax->externalSubset = cb; +} + +void +hslibxml_setcb_startElementNs(xmlParserCtxt *ctx, startElementNsSAX2Func cb) +{ + ctx->sax->startElementNs = cb; +} + +void +hslibxml_setcb_endElementNs(xmlParserCtxt *ctx, endElementNsSAX2Func cb) +{ + ctx->sax->endElementNs = cb; +} + +void +hslibxml_setcb_serror(xmlParserCtxt *ctx, xmlStructuredErrorFunc cb) +{ + ctx->sax->serror = cb; +} diff --git a/cbits/hslibxml-shim.h b/cbits/hslibxml-shim.h new file mode 100644 --- /dev/null +++ b/cbits/hslibxml-shim.h @@ -0,0 +1,174 @@ +#ifndef HSLIBXML_SHIM_H +#define HSLIBXML_SHIM_H + +#include + +/* Versions of the error handling callbacks with fixed arity */ +typedef void(*FixedErrorFunc)(void *ctx, const char *msg); + +xmlParserCtxt * +hslibxml_alloc_parser(const char *filename); + +void +hslibxml_free_parser(xmlParserCtxt *ctx); + +int +hslibxml_want_callback(xmlParserCtxt *ctx, void *cb_ctx); + +internalSubsetSAXFunc +hslibxml_getcb_internalSubset(xmlParserCtxt *ctx); + +isStandaloneSAXFunc +hslibxml_getcb_isStandalone(xmlParserCtxt *ctx); + +hasInternalSubsetSAXFunc +hslibxml_getcb_hasInternalSubset(xmlParserCtxt *ctx); + +hasExternalSubsetSAXFunc +hslibxml_getcb_hasExternalSubset(xmlParserCtxt *ctx); + +xmlExternalEntityLoader +hslibxml_getcb_resolveEntity(xmlParserCtxt *ctx); + +getEntitySAXFunc +hslibxml_getcb_getEntity(xmlParserCtxt *ctx); + +entityDeclSAXFunc +hslibxml_getcb_entityDecl(xmlParserCtxt *ctx); + +notationDeclSAXFunc +hslibxml_getcb_notationDecl(xmlParserCtxt *ctx); + +attributeDeclSAXFunc +hslibxml_getcb_attributeDecl(xmlParserCtxt *ctx); + +elementDeclSAXFunc +hslibxml_getcb_elementDecl(xmlParserCtxt *ctx); + +unparsedEntityDeclSAXFunc +hslibxml_getcb_unparsedEntityDecl(xmlParserCtxt *ctx); + +startDocumentSAXFunc +hslibxml_getcb_startDocument(xmlParserCtxt *ctx); + +endDocumentSAXFunc +hslibxml_getcb_endDocument(xmlParserCtxt *ctx); + +referenceSAXFunc +hslibxml_getcb_reference(xmlParserCtxt *ctx); + +charactersSAXFunc +hslibxml_getcb_characters(xmlParserCtxt *ctx); + +ignorableWhitespaceSAXFunc +hslibxml_getcb_ignorableWhitespace(xmlParserCtxt *ctx); + +processingInstructionSAXFunc +hslibxml_getcb_processingInstruction(xmlParserCtxt *ctx); + +commentSAXFunc +hslibxml_getcb_comment(xmlParserCtxt *ctx); + +FixedErrorFunc +hslibxml_getcb_warning(xmlParserCtxt *ctx); + +FixedErrorFunc +hslibxml_getcb_error(xmlParserCtxt *ctx); + +getParameterEntitySAXFunc +hslibxml_getcb_getParameterEntity(xmlParserCtxt *ctx); + +cdataBlockSAXFunc +hslibxml_getcb_cdataBlock(xmlParserCtxt *ctx); + +externalSubsetSAXFunc +hslibxml_getcb_externalSubset(xmlParserCtxt *ctx); + +startElementNsSAX2Func +hslibxml_getcb_startElementNs(xmlParserCtxt *ctx); + +endElementNsSAX2Func +hslibxml_getcb_endElementNs(xmlParserCtxt *ctx); + +xmlStructuredErrorFunc +hslibxml_getcb_serror(xmlParserCtxt *ctx); + +void +hslibxml_setcb_internalSubset(xmlParserCtxt *ctx, internalSubsetSAXFunc cb); + +void +hslibxml_setcb_isStandalone(xmlParserCtxt *ctx, isStandaloneSAXFunc cb); + +void +hslibxml_setcb_hasInternalSubset(xmlParserCtxt *ctx, hasInternalSubsetSAXFunc cb); + +void +hslibxml_setcb_hasExternalSubset(xmlParserCtxt *ctx, hasExternalSubsetSAXFunc cb); + +void +hslibxml_setcb_resolveEntity(xmlParserCtxt *ctx, xmlExternalEntityLoader cb); + +void +hslibxml_setcb_getEntity(xmlParserCtxt *ctx, getEntitySAXFunc cb); + +void +hslibxml_setcb_entityDecl(xmlParserCtxt *ctx, entityDeclSAXFunc cb); + +void +hslibxml_setcb_notationDecl(xmlParserCtxt *ctx, notationDeclSAXFunc cb); + +void +hslibxml_setcb_attributeDecl(xmlParserCtxt *ctx, attributeDeclSAXFunc cb); + +void +hslibxml_setcb_elementDecl(xmlParserCtxt *ctx, elementDeclSAXFunc cb); + +void +hslibxml_setcb_unparsedEntityDecl(xmlParserCtxt *ctx, unparsedEntityDeclSAXFunc cb); + +void +hslibxml_setcb_startDocument(xmlParserCtxt *ctx, startDocumentSAXFunc cb); + +void +hslibxml_setcb_endDocument(xmlParserCtxt *ctx, endDocumentSAXFunc cb); + +void +hslibxml_setcb_reference(xmlParserCtxt *ctx, referenceSAXFunc cb); + +void +hslibxml_setcb_characters(xmlParserCtxt *ctx, charactersSAXFunc cb); + +void +hslibxml_setcb_ignorableWhitespace(xmlParserCtxt *ctx, ignorableWhitespaceSAXFunc cb); + +void +hslibxml_setcb_processingInstruction(xmlParserCtxt *ctx, processingInstructionSAXFunc cb); + +void +hslibxml_setcb_comment(xmlParserCtxt *ctx, commentSAXFunc cb); + +void +hslibxml_setcb_warning(xmlParserCtxt *ctx, FixedErrorFunc cb); + +void +hslibxml_setcb_error(xmlParserCtxt *ctx, FixedErrorFunc cb); + +void +hslibxml_setcb_getParameterEntity(xmlParserCtxt *ctx, getParameterEntitySAXFunc cb); + +void +hslibxml_setcb_cdataBlock(xmlParserCtxt *ctx, cdataBlockSAXFunc cb); + +void +hslibxml_setcb_externalSubset(xmlParserCtxt *ctx, externalSubsetSAXFunc cb); + +void +hslibxml_setcb_startElementNs(xmlParserCtxt *ctx, startElementNsSAX2Func cb); + +void +hslibxml_setcb_endElementNs(xmlParserCtxt *ctx, endElementNsSAX2Func cb); + +void +hslibxml_setcb_serror(xmlParserCtxt *ctx, xmlStructuredErrorFunc cb); + +#endif diff --git a/hslibxml-shim.c b/hslibxml-shim.c deleted file mode 100644 --- a/hslibxml-shim.c +++ /dev/null @@ -1,464 +0,0 @@ -#define _GNU_SOURCE - -#include "hslibxml-shim.h" -#include -#include - -typedef struct UserData UserData; -struct UserData -{ - FixedErrorFunc warning; - FixedErrorFunc error; - xmlExternalEntityLoader resolveEntity; -}; - -static xmlParserInput * -hslibxml_entity_loader(const char *publicId, const char *systemId, xmlParserCtxt *ctx) -{ - UserData *user_data = (UserData *)ctx->_private; - if (user_data && user_data->resolveEntity) - { - return user_data->resolveEntity(publicId, systemId, ctx); - } - return NULL; -} - -xmlParserCtxt * -hslibxml_alloc_parser(const char *filename) -{ - xmlSAXHandler sax; - xmlParserCtxt *ctx; - UserData *user_data; - - static int entity_resolver_set = 0; - if (entity_resolver_set == 0) - { - entity_resolver_set = 1; - xmlSetExternalEntityLoader(hslibxml_entity_loader); - } - - user_data = calloc(1, sizeof(UserData)); - - memset(&sax, 0, sizeof(xmlSAXHandler)); - sax.initialized = XML_SAX2_MAGIC; - - ctx = xmlCreatePushParserCtxt(&sax, NULL, NULL, 0, filename); - ctx->replaceEntities = 1; - ctx->_private = user_data; - return ctx; -} - -void -hslibxml_free_parser(xmlParserCtxt *ctx) -{ - xmlFreeParserCtxt(ctx); -} - -int -hslibxml_want_callback(xmlParserCtxt *ctx, void *cb_ctx) -{ - if (ctx->replaceEntities) - { - return 1; - } - - return (ctx == cb_ctx); -} - -internalSubsetSAXFunc -hslibxml_getcb_internalSubset(xmlParserCtxt *ctx) -{ - return ctx->sax->internalSubset; -} - -isStandaloneSAXFunc -hslibxml_getcb_isStandalone(xmlParserCtxt *ctx) -{ - return ctx->sax->isStandalone; -} - -hasInternalSubsetSAXFunc -hslibxml_getcb_hasInternalSubset(xmlParserCtxt *ctx) -{ - return ctx->sax->hasInternalSubset; -} - -hasExternalSubsetSAXFunc -hslibxml_getcb_hasExternalSubset(xmlParserCtxt *ctx) -{ - return ctx->sax->hasExternalSubset; -} - -xmlExternalEntityLoader -hslibxml_getcb_resolveEntity(xmlParserCtxt *ctx) -{ - UserData *user_data = (UserData *)ctx->_private; - return user_data->resolveEntity; -} - -getEntitySAXFunc -hslibxml_getcb_getEntity(xmlParserCtxt *ctx) -{ - return ctx->sax->getEntity; -} - -entityDeclSAXFunc -hslibxml_getcb_entityDecl(xmlParserCtxt *ctx) -{ - return ctx->sax->entityDecl; -} - -notationDeclSAXFunc -hslibxml_getcb_notationDecl(xmlParserCtxt *ctx) -{ - return ctx->sax->notationDecl; -} - -attributeDeclSAXFunc -hslibxml_getcb_attributeDecl(xmlParserCtxt *ctx) -{ - return ctx->sax->attributeDecl; -} - -elementDeclSAXFunc -hslibxml_getcb_elementDecl(xmlParserCtxt *ctx) -{ - return ctx->sax->elementDecl; -} - -unparsedEntityDeclSAXFunc -hslibxml_getcb_unparsedEntityDecl(xmlParserCtxt *ctx) -{ - return ctx->sax->unparsedEntityDecl; -} - -startDocumentSAXFunc -hslibxml_getcb_startDocument(xmlParserCtxt *ctx) -{ - return ctx->sax->startDocument; -} - -endDocumentSAXFunc -hslibxml_getcb_endDocument(xmlParserCtxt *ctx) -{ - return ctx->sax->endDocument; -} - -referenceSAXFunc -hslibxml_getcb_reference(xmlParserCtxt *ctx) -{ - return ctx->sax->reference; -} - -charactersSAXFunc -hslibxml_getcb_characters(xmlParserCtxt *ctx) -{ - return ctx->sax->characters; -} - -ignorableWhitespaceSAXFunc -hslibxml_getcb_ignorableWhitespace(xmlParserCtxt *ctx) -{ - return ctx->sax->ignorableWhitespace; -} - -processingInstructionSAXFunc -hslibxml_getcb_processingInstruction(xmlParserCtxt *ctx) -{ - return ctx->sax->processingInstruction; -} - -commentSAXFunc -hslibxml_getcb_comment(xmlParserCtxt *ctx) -{ - return ctx->sax->comment; -} - -FixedErrorFunc -hslibxml_getcb_warning(xmlParserCtxt *ctx) -{ - UserData *user_data = (UserData *)ctx->_private; - return user_data->warning; -} - -FixedErrorFunc -hslibxml_getcb_error(xmlParserCtxt *ctx) -{ - UserData *user_data = (UserData *)ctx->_private; - return user_data->error; -} - -fatalErrorSAXFunc -hslibxml_getcb_fatalError(xmlParserCtxt *ctx) -{ - return ctx->sax->fatalError; -} - -getParameterEntitySAXFunc -hslibxml_getcb_getParameterEntity(xmlParserCtxt *ctx) -{ - return ctx->sax->getParameterEntity; -} - -cdataBlockSAXFunc -hslibxml_getcb_cdataBlock(xmlParserCtxt *ctx) -{ - return ctx->sax->cdataBlock; -} - -externalSubsetSAXFunc -hslibxml_getcb_externalSubset(xmlParserCtxt *ctx) -{ - return ctx->sax->externalSubset; -} - -startElementNsSAX2Func -hslibxml_getcb_startElementNs(xmlParserCtxt *ctx) -{ - return ctx->sax->startElementNs; -} - -endElementNsSAX2Func -hslibxml_getcb_endElementNs(xmlParserCtxt *ctx) -{ - return ctx->sax->endElementNs; -} - -xmlStructuredErrorFunc -hslibxml_getcb_serror(xmlParserCtxt *ctx) -{ - return ctx->sax->serror; -} - -void -hslibxml_setcb_internalSubset(xmlParserCtxt *ctx, internalSubsetSAXFunc cb) -{ - ctx->sax->internalSubset = cb; -} - -void -hslibxml_setcb_isStandalone(xmlParserCtxt *ctx, isStandaloneSAXFunc cb) -{ - ctx->sax->isStandalone = cb; -} - -void -hslibxml_setcb_hasInternalSubset(xmlParserCtxt *ctx, hasInternalSubsetSAXFunc cb) -{ - ctx->sax->hasInternalSubset = cb; -} - -void -hslibxml_setcb_hasExternalSubset(xmlParserCtxt *ctx, hasExternalSubsetSAXFunc cb) -{ - ctx->sax->hasExternalSubset = cb; -} - -void -hslibxml_setcb_resolveEntity(xmlParserCtxt *ctx, xmlExternalEntityLoader cb) -{ - UserData *user_data = (UserData *)ctx->_private; - user_data->resolveEntity = cb; -} - -void -hslibxml_setcb_getEntity(xmlParserCtxt *ctx, getEntitySAXFunc cb) -{ - ctx->sax->getEntity = cb; -} - -void -hslibxml_setcb_entityDecl(xmlParserCtxt *ctx, entityDeclSAXFunc cb) -{ - ctx->sax->entityDecl = cb; -} - -void -hslibxml_setcb_notationDecl(xmlParserCtxt *ctx, notationDeclSAXFunc cb) -{ - ctx->sax->notationDecl = cb; -} - -void -hslibxml_setcb_attributeDecl(xmlParserCtxt *ctx, attributeDeclSAXFunc cb) -{ - ctx->sax->attributeDecl = cb; -} - -void -hslibxml_setcb_elementDecl(xmlParserCtxt *ctx, elementDeclSAXFunc cb) -{ - ctx->sax->elementDecl = cb; -} - -void -hslibxml_setcb_unparsedEntityDecl(xmlParserCtxt *ctx, unparsedEntityDeclSAXFunc cb) -{ - ctx->sax->unparsedEntityDecl = cb; -} - -void -hslibxml_setcb_startDocument(xmlParserCtxt *ctx, startDocumentSAXFunc cb) -{ - ctx->sax->startDocument = cb; -} - -void -hslibxml_setcb_endDocument(xmlParserCtxt *ctx, endDocumentSAXFunc cb) -{ - ctx->sax->endDocument = cb; -} - -void -hslibxml_setcb_reference(xmlParserCtxt *ctx, referenceSAXFunc cb) -{ - ctx->sax->reference = cb; - - if (cb == NULL) - { ctx->replaceEntities = 1; } - - else - { ctx->replaceEntities = 0; } -} - -void -hslibxml_setcb_characters(xmlParserCtxt *ctx, charactersSAXFunc cb) -{ - ctx->sax->characters = cb; -} - -void -hslibxml_setcb_ignorableWhitespace(xmlParserCtxt *ctx, ignorableWhitespaceSAXFunc cb) -{ - ctx->sax->ignorableWhitespace = cb; -} - -void -hslibxml_setcb_processingInstruction(xmlParserCtxt *ctx, processingInstructionSAXFunc cb) -{ - ctx->sax->processingInstruction = cb; -} - -void -hslibxml_setcb_comment(xmlParserCtxt *ctx, commentSAXFunc cb) -{ - ctx->sax->comment = cb; -} - -static void -hslibxml_on_warning(void *data, const char *format, ...) -{ - xmlParserCtxt *ctx; - UserData *user_data; - char *msg; - va_list params; - int rc; - - ctx = (xmlParserCtxt *)data; - user_data = (UserData *)ctx->_private; - - va_start(params, format); - rc = vasprintf(&msg, format, params); - if (rc == -1) - { - /* try to get something to the user */ - user_data->warning(ctx, format); - return; - } - - user_data->warning(ctx, msg); - free(msg); -} - -static void -hslibxml_on_error(void *data, const char *format, ...) -{ - xmlParserCtxt *ctx; - UserData *user_data; - char *msg; - va_list params; - int rc; - - ctx = (xmlParserCtxt *)data; - user_data = (UserData *)ctx->_private; - - va_start(params, format); - rc = vasprintf(&msg, format, params); - if (rc == -1) - { - /* try to get something to the user */ - user_data->error(ctx, format); - return; - } - - user_data->error(ctx, msg); - free(msg); -} - -void -hslibxml_setcb_warning(xmlParserCtxt *ctx, FixedErrorFunc cb) -{ - UserData *user_data = (UserData *)ctx->_private; - if (cb == NULL) - { ctx->sax->warning = NULL; } - - else - { ctx->sax->warning = hslibxml_on_warning; } - - user_data->warning = cb; -} - -void -hslibxml_setcb_error(xmlParserCtxt *ctx, FixedErrorFunc cb) -{ - UserData *user_data = (UserData *)ctx->_private; - if (cb == NULL) - { ctx->sax->error = NULL; } - - else - { ctx->sax->error = hslibxml_on_error; } - - user_data->error = cb; -} - -void -hslibxml_setcb_fatalError(xmlParserCtxt *ctx, fatalErrorSAXFunc cb) -{ - ctx->sax->fatalError = cb; -} - -void -hslibxml_setcb_getParameterEntity(xmlParserCtxt *ctx, getParameterEntitySAXFunc cb) -{ - ctx->sax->getParameterEntity = cb; -} - -void -hslibxml_setcb_cdataBlock(xmlParserCtxt *ctx, cdataBlockSAXFunc cb) -{ - ctx->sax->cdataBlock = cb; -} - -void -hslibxml_setcb_externalSubset(xmlParserCtxt *ctx, externalSubsetSAXFunc cb) -{ - ctx->sax->externalSubset = cb; -} - -void -hslibxml_setcb_startElementNs(xmlParserCtxt *ctx, startElementNsSAX2Func cb) -{ - ctx->sax->startElementNs = cb; -} - -void -hslibxml_setcb_endElementNs(xmlParserCtxt *ctx, endElementNsSAX2Func cb) -{ - ctx->sax->endElementNs = cb; -} - -void -hslibxml_setcb_serror(xmlParserCtxt *ctx, xmlStructuredErrorFunc cb) -{ - ctx->sax->serror = cb; -} diff --git a/hslibxml-shim.h b/hslibxml-shim.h deleted file mode 100644 --- a/hslibxml-shim.h +++ /dev/null @@ -1,174 +0,0 @@ -#ifndef HSLIBXML_SHIM_H -#define HSLIBXML_SHIM_H - -#include - -/* Versions of the error handling callbacks with fixed arity */ -typedef void(*FixedErrorFunc)(void *ctx, const char *msg); - -xmlParserCtxt * -hslibxml_alloc_parser(const char *filename); - -void -hslibxml_free_parser(xmlParserCtxt *ctx); - -int -hslibxml_want_callback(xmlParserCtxt *ctx, void *cb_ctx); - -internalSubsetSAXFunc -hslibxml_getcb_internalSubset(xmlParserCtxt *ctx); - -isStandaloneSAXFunc -hslibxml_getcb_isStandalone(xmlParserCtxt *ctx); - -hasInternalSubsetSAXFunc -hslibxml_getcb_hasInternalSubset(xmlParserCtxt *ctx); - -hasExternalSubsetSAXFunc -hslibxml_getcb_hasExternalSubset(xmlParserCtxt *ctx); - -xmlExternalEntityLoader -hslibxml_getcb_resolveEntity(xmlParserCtxt *ctx); - -getEntitySAXFunc -hslibxml_getcb_getEntity(xmlParserCtxt *ctx); - -entityDeclSAXFunc -hslibxml_getcb_entityDecl(xmlParserCtxt *ctx); - -notationDeclSAXFunc -hslibxml_getcb_notationDecl(xmlParserCtxt *ctx); - -attributeDeclSAXFunc -hslibxml_getcb_attributeDecl(xmlParserCtxt *ctx); - -elementDeclSAXFunc -hslibxml_getcb_elementDecl(xmlParserCtxt *ctx); - -unparsedEntityDeclSAXFunc -hslibxml_getcb_unparsedEntityDecl(xmlParserCtxt *ctx); - -startDocumentSAXFunc -hslibxml_getcb_startDocument(xmlParserCtxt *ctx); - -endDocumentSAXFunc -hslibxml_getcb_endDocument(xmlParserCtxt *ctx); - -referenceSAXFunc -hslibxml_getcb_reference(xmlParserCtxt *ctx); - -charactersSAXFunc -hslibxml_getcb_characters(xmlParserCtxt *ctx); - -ignorableWhitespaceSAXFunc -hslibxml_getcb_ignorableWhitespace(xmlParserCtxt *ctx); - -processingInstructionSAXFunc -hslibxml_getcb_processingInstruction(xmlParserCtxt *ctx); - -commentSAXFunc -hslibxml_getcb_comment(xmlParserCtxt *ctx); - -FixedErrorFunc -hslibxml_getcb_warning(xmlParserCtxt *ctx); - -FixedErrorFunc -hslibxml_getcb_error(xmlParserCtxt *ctx); - -getParameterEntitySAXFunc -hslibxml_getcb_getParameterEntity(xmlParserCtxt *ctx); - -cdataBlockSAXFunc -hslibxml_getcb_cdataBlock(xmlParserCtxt *ctx); - -externalSubsetSAXFunc -hslibxml_getcb_externalSubset(xmlParserCtxt *ctx); - -startElementNsSAX2Func -hslibxml_getcb_startElementNs(xmlParserCtxt *ctx); - -endElementNsSAX2Func -hslibxml_getcb_endElementNs(xmlParserCtxt *ctx); - -xmlStructuredErrorFunc -hslibxml_getcb_serror(xmlParserCtxt *ctx); - -void -hslibxml_setcb_internalSubset(xmlParserCtxt *ctx, internalSubsetSAXFunc cb); - -void -hslibxml_setcb_isStandalone(xmlParserCtxt *ctx, isStandaloneSAXFunc cb); - -void -hslibxml_setcb_hasInternalSubset(xmlParserCtxt *ctx, hasInternalSubsetSAXFunc cb); - -void -hslibxml_setcb_hasExternalSubset(xmlParserCtxt *ctx, hasExternalSubsetSAXFunc cb); - -void -hslibxml_setcb_resolveEntity(xmlParserCtxt *ctx, xmlExternalEntityLoader cb); - -void -hslibxml_setcb_getEntity(xmlParserCtxt *ctx, getEntitySAXFunc cb); - -void -hslibxml_setcb_entityDecl(xmlParserCtxt *ctx, entityDeclSAXFunc cb); - -void -hslibxml_setcb_notationDecl(xmlParserCtxt *ctx, notationDeclSAXFunc cb); - -void -hslibxml_setcb_attributeDecl(xmlParserCtxt *ctx, attributeDeclSAXFunc cb); - -void -hslibxml_setcb_elementDecl(xmlParserCtxt *ctx, elementDeclSAXFunc cb); - -void -hslibxml_setcb_unparsedEntityDecl(xmlParserCtxt *ctx, unparsedEntityDeclSAXFunc cb); - -void -hslibxml_setcb_startDocument(xmlParserCtxt *ctx, startDocumentSAXFunc cb); - -void -hslibxml_setcb_endDocument(xmlParserCtxt *ctx, endDocumentSAXFunc cb); - -void -hslibxml_setcb_reference(xmlParserCtxt *ctx, referenceSAXFunc cb); - -void -hslibxml_setcb_characters(xmlParserCtxt *ctx, charactersSAXFunc cb); - -void -hslibxml_setcb_ignorableWhitespace(xmlParserCtxt *ctx, ignorableWhitespaceSAXFunc cb); - -void -hslibxml_setcb_processingInstruction(xmlParserCtxt *ctx, processingInstructionSAXFunc cb); - -void -hslibxml_setcb_comment(xmlParserCtxt *ctx, commentSAXFunc cb); - -void -hslibxml_setcb_warning(xmlParserCtxt *ctx, FixedErrorFunc cb); - -void -hslibxml_setcb_error(xmlParserCtxt *ctx, FixedErrorFunc cb); - -void -hslibxml_setcb_getParameterEntity(xmlParserCtxt *ctx, getParameterEntitySAXFunc cb); - -void -hslibxml_setcb_cdataBlock(xmlParserCtxt *ctx, cdataBlockSAXFunc cb); - -void -hslibxml_setcb_externalSubset(xmlParserCtxt *ctx, externalSubsetSAXFunc cb); - -void -hslibxml_setcb_startElementNs(xmlParserCtxt *ctx, startElementNsSAX2Func cb); - -void -hslibxml_setcb_endElementNs(xmlParserCtxt *ctx, endElementNsSAX2Func cb); - -void -hslibxml_setcb_serror(xmlParserCtxt *ctx, xmlStructuredErrorFunc cb); - -#endif diff --git a/lib/Text/XML/LibXML/SAX.hs b/lib/Text/XML/LibXML/SAX.hs new file mode 100644 --- /dev/null +++ b/lib/Text/XML/LibXML/SAX.hs @@ -0,0 +1,756 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- | +-- Module: Text.XML.LibXML.SAX +-- Copyright: 2010 John Millikin +-- License: MIT +-- +-- Maintainer: jmillikin@gmail.com +-- Portability: portable +-- +-- Bindings for the libXML2 SAX interface +-- +----------------------------------------------------------------------------- + +module Text.XML.LibXML.SAX + ( + -- * Parser + Parser + , newParserIO + , newParserST + + -- ** Parser input + , parseBytes + , parseComplete + + -- * Callbacks + , Callback + , setCallback + , clearCallback + + -- ** Parse events + , parsedBeginDocument + , parsedEndDocument + , parsedBeginElement + , parsedEndElement + , parsedCharacters + , parsedReference + , parsedComment + , parsedInstruction + , parsedCDATA + , parsedWhitespace + , parsedInternalSubset + , parsedExternalSubset + + -- ** Warning and error reporting + , reportWarning + , reportError + + ) where + +import qualified Control.Exception as E +import Control.Monad (when, unless) +import qualified Control.Monad.ST as ST + +#if MIN_VERSION_base(4,4,0) +import Control.Monad.ST.Unsafe (unsafeIOToST, unsafeSTToIO) +#else +import Control.Monad.ST (unsafeIOToST, unsafeSTToIO) +#endif + +import qualified Data.ByteString as B +import qualified Data.ByteString.Unsafe as BU +import Data.Char (chr, isDigit) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.XML.Types as X +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import Foreign hiding (free) +import Foreign.C +import qualified Foreign.Concurrent as FC +import Text.ParserCombinators.ReadP ((+++)) +import qualified Text.ParserCombinators.ReadP as ReadP + +data Context = Context + +-- | A 'Parser' tracks the internal state of a LibXML parser context. +-- +-- As LibXML is a very stateful library, parsers must operate within either +-- the 'IO' or 'ST.ST' monad. Use 'newParserIO' or 'newParserST' to create +-- parsers in the appropriate monad. +-- +-- In general, clients should prefer 'newParserST', because ST values can be +-- safely computed with no side effects. +data Parser m = Parser + { parserHandle :: ForeignPtr Context + , parserErrorRef :: IORef (Maybe E.SomeException) + , parserToIO :: forall a. m a -> IO a + , parserFromIO :: forall a. IO a -> m a + } + +newParserIO :: Maybe T.Text -- ^ An optional filename or URI + -> IO (Parser IO) +newParserIO filename = mask $ \_ -> do + ref <- newIORef Nothing + + raw <- maybeWith withUTF8 filename cAllocParser + managed <- newForeignPtr_ raw + + FC.addForeignPtrFinalizer managed (cFreeParser raw) + FC.addForeignPtrFinalizer managed (freeCallbacks raw) + + return (Parser managed ref id id) + +newParserST :: Maybe T.Text -- ^ An optional filename or URI + -> ST.ST s (Parser (ST.ST s)) +newParserST filename = unsafeIOToST $ do + p <- newParserIO filename + return $ p + { parserToIO = unsafeSTToIO + , parserFromIO = unsafeIOToST + } + +parseImpl :: Parser m -> (Ptr Context -> IO CInt) -> m () +parseImpl p io = parserFromIO p $ do + writeIORef (parserErrorRef p) Nothing + _ <- mask (\_ -> withParserIO p io) + + threw <- readIORef (parserErrorRef p) + case threw of + Nothing -> return () + Just exc -> E.throwIO exc + +parseBytes :: Parser m -> B.ByteString -> m () +parseBytes p bytes = parseImpl p $ \h -> + BU.unsafeUseAsCStringLen bytes $ \(cstr, len) -> + cParseChunk h cstr (fromIntegral len) 0 + +-- | Finish parsing any buffered data, and check that the document was +-- closed correctly. +-- +parseComplete :: Parser m -> m () +parseComplete p = parseImpl p (\h -> cParseChunk h nullPtr 0 1) + +-- Callbacks {{{ + +freeCallbacks :: Ptr Context -> IO () +freeCallbacks ctx = do + getcb_startDocument ctx >>= freeFunPtr + getcb_endDocument ctx >>= freeFunPtr + getcb_startElementNs ctx >>= freeFunPtr + getcb_endElementNs ctx >>= freeFunPtr + getcb_characters ctx >>= freeFunPtr + getcb_reference ctx >>= freeFunPtr + getcb_comment ctx >>= freeFunPtr + getcb_processingInstruction ctx >>= freeFunPtr + getcb_cdataBlock ctx >>= freeFunPtr + getcb_ignorableWhitespace ctx >>= freeFunPtr + getcb_internalSubset ctx >>= freeFunPtr + getcb_externalSubset ctx >>= freeFunPtr + getcb_warning ctx >>= freeFunPtr + getcb_error ctx >>= freeFunPtr + +data Callback m a = Callback (Parser m -> a -> IO ()) (Parser m -> IO ()) + +-- | Set a callback computation to run when a particular parse event occurs. +-- The callback should return 'True' to continue parsing, or 'False' +-- to abort. +-- +-- Alternatively, callbacks may throw an 'E.Exception' to abort parsing. The +-- exception will be propagated through to the caller of 'parseBytes' or +-- 'parseComplete'. +setCallback :: Parser m -> Callback m a -> a -> m () +setCallback p (Callback set _) io = parserFromIO p (set p io) + +-- | Remove a callback from the parser. This might also change the parser's +-- behavior, such as automatically expanding entity references when no +-- 'parsedReference' callback is set. +clearCallback :: Parser m -> Callback m a -> m () +clearCallback p (Callback _ clear) = parserFromIO p (clear p) + +catchRef :: Parser m -> Ptr Context -> m Bool -> IO () +catchRef p cb_ctx io = withParserIO p $ \ctx -> + (cWantCallback ctx cb_ctx >>=) $ \want -> + when (want == 1) $ do + continue <- E.catch (parserToIO p io) $ \e -> do + writeIORef (parserErrorRef p) (Just e) + return False + unless continue (cStopParser ctx) + +catchRefIO :: Parser m -> Ptr Context -> IO Bool -> IO () +catchRefIO p cb_ctx io = catchRef p cb_ctx (parserFromIO p io) + +callback :: (Parser m -> a -> IO (FunPtr b)) + -> (Ptr Context -> IO (FunPtr b)) + -> (Ptr Context -> FunPtr b -> IO ()) + -> Callback m a +callback wrap getPtr setPtr = Callback set clear where + set p io = withForeignPtr (parserHandle p) $ \ctx -> do + free ctx + wrap p io >>= setPtr ctx + clear p = withForeignPtr (parserHandle p) $ \ctx -> do + free ctx + setPtr ctx nullFunPtr + free ctx = getPtr ctx >>= freeFunPtr + +-- begin document {{{ + +parsedBeginDocument :: Callback m (m Bool) +parsedBeginDocument = callback wrap_startDocument + getcb_startDocument + setcb_startDocument + +type StartDocumentSAXFunc = Ptr Context -> IO () + +wrap_startDocument :: Parser m -> m Bool -> IO (FunPtr StartDocumentSAXFunc) +wrap_startDocument p io = newcb_startDocument (\ctx -> catchRef p ctx io) + +foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_startDocument" + getcb_startDocument :: Ptr Context -> IO (FunPtr StartDocumentSAXFunc) + +foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_startDocument" + setcb_startDocument :: Ptr Context -> FunPtr StartDocumentSAXFunc -> IO () + +foreign import ccall "wrapper" + newcb_startDocument :: StartDocumentSAXFunc -> IO (FunPtr StartDocumentSAXFunc) + +-- }}} + +-- end document {{{ + +parsedEndDocument :: Callback m (m Bool) +parsedEndDocument = callback wrap_endDocument + getcb_endDocument + setcb_endDocument + +type EndDocumentSAXFunc = Ptr Context -> IO () + +wrap_endDocument :: Parser m -> m Bool -> IO (FunPtr EndDocumentSAXFunc) +wrap_endDocument p io = newcb_endDocument (\ctx -> catchRef p ctx io) + +foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_endDocument" + getcb_endDocument :: Ptr Context -> IO (FunPtr EndDocumentSAXFunc) + +foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_endDocument" + setcb_endDocument :: Ptr Context -> FunPtr EndDocumentSAXFunc -> IO () + +foreign import ccall "wrapper" + newcb_endDocument :: EndDocumentSAXFunc -> IO (FunPtr EndDocumentSAXFunc) + +-- }}} + +-- begin element {{{ + +parsedBeginElement :: Callback m (X.Name -> [(X.Name, [X.Content])] -> m Bool) +parsedBeginElement = callback wrap_beginElement + getcb_startElementNs + setcb_startElementNs + +type StartElementNsSAX2Func = (Ptr Context -> CString -> CString -> CString -> CInt -> Ptr CString -> CInt -> CInt -> Ptr CString -> IO ()) + +wrap_beginElement :: Parser m -> (X.Name -> [(X.Name, [X.Content])] -> m Bool) -> IO (FunPtr StartElementNsSAX2Func) +wrap_beginElement p io = + newcb_startElementNs $ \ctx cln cpfx cns _ _ n_attrs _ raw_attrs -> + catchRefIO p ctx $ do + refCB <- getcb_reference ctx + let hasRefCB = refCB /= nullFunPtr + + ns <- maybePeek peekUTF8 (castPtr cns) + pfx <- maybePeek peekUTF8 (castPtr cpfx) + ln <- peekUTF8 (castPtr cln) + attrs <- peekAttributes hasRefCB (castPtr raw_attrs) n_attrs + parserToIO p (io (X.Name ln ns pfx) attrs) + +foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_startElementNs" + getcb_startElementNs :: Ptr Context -> IO (FunPtr StartElementNsSAX2Func) + +foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_startElementNs" + setcb_startElementNs :: Ptr Context -> FunPtr StartElementNsSAX2Func -> IO () + +foreign import ccall "wrapper" + newcb_startElementNs :: StartElementNsSAX2Func -> IO (FunPtr StartElementNsSAX2Func) + +peekAttributes :: Bool -> Ptr CString -> CInt -> IO [(X.Name, [X.Content])] +peekAttributes hasRefCB ptr = loop 0 where + loop _ 0 = return [] + loop offset n = do + local <- peekUTF8 =<< peekElemOff ptr (offset + 0) + prefix <- maybePeek peekUTF8 =<< peekElemOff ptr (offset + 1) + ns <- maybePeek peekUTF8 =<< peekElemOff ptr (offset + 2) + + val_begin <- peekElemOff ptr (offset + 3) + val_end <- peekElemOff ptr (offset + 4) + val <- peekUTF8Len (val_begin, minusPtr val_end val_begin) + + let content = if hasRefCB + then parseAttributeContent val + else [X.ContentText val] + let attr = (X.Name local ns prefix, content) + attrs <- loop (offset + 5) (n - 1) + + return (attr:attrs) + +parseAttributeContent :: T.Text -> [X.Content] +parseAttributeContent = parse . T.unpack where + parse chars = case ReadP.readP_to_S parser chars of + (cs,_):_ -> cs + _ -> error "parseAttributeContent: no parse" + parser = ReadP.manyTill content eof + content = charRef +++ reference +++ text + charRef = do + _ <- ReadP.string "&#" + val <- ReadP.munch1 (isDigit) + _ <- ReadP.char ';' + return (X.ContentText (T.singleton (chr (read val)))) + reference = do + _ <- ReadP.char '&' + name <- ReadP.munch1 (/= ';') + _ <- ReadP.char ';' + return (X.ContentEntity (T.pack name)) + text = do + chars <- ReadP.munch1 (/= '&') + return (X.ContentText (T.pack chars)) + +#if MIN_VERSION_base(4,2,0) + eof = ReadP.eof +#else + eof = do + s <- ReadP.look + unless (null s) ReadP.pfail +#endif + +-- }}} + +-- end element {{{ + +parsedEndElement :: Callback m (X.Name -> m Bool) +parsedEndElement = callback wrap_endElementNs + getcb_endElementNs + setcb_endElementNs + +type EndElementNsSAX2Func = (Ptr Context -> CString -> CString -> CString -> IO ()) + +wrap_endElementNs :: Parser m -> (X.Name -> m Bool) -> IO (FunPtr EndElementNsSAX2Func) +wrap_endElementNs p io = + newcb_endElementNs $ \ctx cln cpfx cns -> + catchRefIO p ctx $ do + ns <- maybePeek peekUTF8 (castPtr cns) + prefix <- maybePeek peekUTF8 (castPtr cpfx) + local <- peekUTF8 (castPtr cln) + parserToIO p (io (X.Name local ns prefix)) + +foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_endElementNs" + getcb_endElementNs :: Ptr Context -> IO (FunPtr EndElementNsSAX2Func) + +foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_endElementNs" + setcb_endElementNs :: Ptr Context -> FunPtr EndElementNsSAX2Func -> IO () + +foreign import ccall "wrapper" + newcb_endElementNs :: EndElementNsSAX2Func -> IO (FunPtr EndElementNsSAX2Func) + +-- }}} + +-- characters, cdata, and whitespace {{{ + +parsedCharacters :: Callback m (T.Text -> m Bool) +parsedCharacters = callback wrap_characters + getcb_characters + setcb_characters + +-- | If 'parsedCDATA' is set, it receives any text contained in CDATA +-- blocks. By default, all text is received by 'parsedCharacters'. +parsedCDATA :: Callback m (T.Text -> m Bool) +parsedCDATA = callback wrap_characters + getcb_cdataBlock + setcb_cdataBlock + +-- | If 'parsedWhitespace' is set, it receives any whitespace marked as +-- ignorable by the document's DTD. By default, all text is received by +-- 'parsedCharacters'. +parsedWhitespace :: Callback m (T.Text -> m Bool) +parsedWhitespace = callback wrap_characters + getcb_ignorableWhitespace + setcb_ignorableWhitespace + +type CharactersSAXFunc = (Ptr Context -> CString -> CInt -> IO ()) + +wrap_characters :: Parser m -> (T.Text -> m Bool) -> IO (FunPtr CharactersSAXFunc) +wrap_characters p io = + newcb_characters $ \ctx cstr clen -> + catchRefIO p ctx $ do + text <- peekUTF8Len (castPtr cstr, fromIntegral clen) + parserToIO p (io text) + +foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_characters" + getcb_characters :: Ptr Context -> IO (FunPtr CharactersSAXFunc) + +foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_cdataBlock" + getcb_cdataBlock :: Ptr Context -> IO (FunPtr CharactersSAXFunc) + +foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_ignorableWhitespace" + getcb_ignorableWhitespace :: Ptr Context -> IO (FunPtr CharactersSAXFunc) + +foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_characters" + setcb_characters :: Ptr Context -> FunPtr CharactersSAXFunc -> IO () + +foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_cdataBlock" + setcb_cdataBlock :: Ptr Context -> FunPtr CharactersSAXFunc -> IO () + +foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_ignorableWhitespace" + setcb_ignorableWhitespace :: Ptr Context -> FunPtr CharactersSAXFunc -> IO () + +foreign import ccall "wrapper" + newcb_characters :: CharactersSAXFunc -> IO (FunPtr CharactersSAXFunc) + +-- }}} + +-- entity reference {{{ + +-- | If 'parsedReference' is set, entity references in element and attribute +-- content will reported separately from text, and will not be automatically +-- expanded. +-- +-- Use this when processing documents in passthrough mode, to preserve +-- existing entity references. +parsedReference :: Callback m (T.Text -> m Bool) +parsedReference = callback wrap_reference + getcb_reference + setcb_reference + +type ReferenceSAXFunc = Ptr Context -> CString -> IO () + +wrap_reference :: Parser m -> (T.Text -> m Bool) -> IO (FunPtr ReferenceSAXFunc) +wrap_reference p io = + newcb_reference $ \ctx cstr -> + catchRefIO p ctx $ do + text <- peekUTF8 (castPtr cstr) + parserToIO p (io text) + +foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_reference" + getcb_reference :: Ptr Context -> IO (FunPtr ReferenceSAXFunc) + +foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_reference" + setcb_reference :: Ptr Context -> FunPtr ReferenceSAXFunc -> IO () + +foreign import ccall "wrapper" + newcb_reference :: ReferenceSAXFunc -> IO (FunPtr ReferenceSAXFunc) + +-- }}} + +-- comment {{{ + +parsedComment :: Callback m (T.Text -> m Bool) +parsedComment = callback wrap_comment + getcb_comment + setcb_comment + +type CommentSAXFunc = Ptr Context -> CString -> IO () + +wrap_comment :: Parser m -> (T.Text -> m Bool) -> IO (FunPtr CommentSAXFunc) +wrap_comment p io = + newcb_comment $ \ctx cstr -> + catchRefIO p ctx $ do + text <- peekUTF8 (castPtr cstr) + parserToIO p (io text) + +foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_comment" + getcb_comment :: Ptr Context -> IO (FunPtr CommentSAXFunc) + +foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_comment" + setcb_comment :: Ptr Context -> FunPtr CommentSAXFunc -> IO () + +foreign import ccall "wrapper" + newcb_comment :: CommentSAXFunc -> IO (FunPtr CommentSAXFunc) + +-- }}} + +-- processing instruction {{{ + +parsedInstruction :: Callback m (X.Instruction -> m Bool) +parsedInstruction = callback wrap_processingInstruction + getcb_processingInstruction + setcb_processingInstruction + +type ProcessingInstructionSAXFunc = Ptr Context -> CString -> CString -> IO () + +wrap_processingInstruction :: Parser m -> (X.Instruction -> m Bool) -> IO (FunPtr ProcessingInstructionSAXFunc) +wrap_processingInstruction p io = + newcb_processingInstruction $ \ctx ctarget cdata -> + catchRefIO p ctx $ do + target <- peekUTF8 (castPtr ctarget) + value <- peekUTF8 (castPtr cdata) + parserToIO p (io (X.Instruction target value)) + +foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_processingInstruction" + getcb_processingInstruction :: Ptr Context -> IO (FunPtr ProcessingInstructionSAXFunc) + +foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_processingInstruction" + setcb_processingInstruction :: Ptr Context -> FunPtr ProcessingInstructionSAXFunc -> IO () + +foreign import ccall "wrapper" + newcb_processingInstruction :: ProcessingInstructionSAXFunc -> IO (FunPtr ProcessingInstructionSAXFunc) + +-- }}} + +-- external subset {{{ + +parsedExternalSubset :: Callback m (T.Text -> Maybe X.ExternalID -> m Bool) +parsedExternalSubset = callback wrap_externalSubset + getcb_externalSubset + setcb_externalSubset + +type ExternalSubsetSAXFunc = Ptr Context -> CString -> CString -> CString -> IO () + +wrap_externalSubset :: Parser m -> (T.Text -> Maybe X.ExternalID -> m Bool) -> IO (FunPtr ExternalSubsetSAXFunc) +wrap_externalSubset p io = + newcb_externalSubset $ \ctx cname cpublic csystem -> + catchRefIO p ctx $ do + name <- peekUTF8 (castPtr cname) + public <- maybePeek peekUTF8 (castPtr cpublic) + system <- maybePeek peekUTF8 (castPtr csystem) + let external = case (public, system) of + (Nothing, Just s) -> Just (X.SystemID s) + (Just p', Just s) -> Just (X.PublicID p' s) + _ -> Nothing + parserToIO p (io name external) + +foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_externalSubset" + getcb_externalSubset :: Ptr Context -> IO (FunPtr ExternalSubsetSAXFunc) + +foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_externalSubset" + setcb_externalSubset :: Ptr Context -> FunPtr ExternalSubsetSAXFunc -> IO () + +foreign import ccall "wrapper" + newcb_externalSubset :: ExternalSubsetSAXFunc -> IO (FunPtr ExternalSubsetSAXFunc) + +-- }}} + +-- internal subset {{{ + +parsedInternalSubset :: Callback m (T.Text -> Maybe X.ExternalID -> m Bool) +parsedInternalSubset = callback wrap_internalSubset + getcb_internalSubset + setcb_internalSubset + +type InternalSubsetSAXFunc = Ptr Context -> CString -> CString -> CString -> IO () + +wrap_internalSubset :: Parser m -> (T.Text -> Maybe X.ExternalID -> m Bool) -> IO (FunPtr InternalSubsetSAXFunc) +wrap_internalSubset p io = + newcb_internalSubset $ \ctx cname cpublic csystem -> + catchRefIO p ctx $ do + name <- peekUTF8 (castPtr cname) + public <- maybePeek peekUTF8 (castPtr cpublic) + system <- maybePeek peekUTF8 (castPtr csystem) + let external = case (public, system) of + (Nothing, Just s) -> Just (X.SystemID s) + (Just p', Just s) -> Just (X.PublicID p' s) + _ -> Nothing + parserToIO p (io name external) + +foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_internalSubset" + getcb_internalSubset :: Ptr Context -> IO (FunPtr InternalSubsetSAXFunc) + +foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_internalSubset" + setcb_internalSubset :: Ptr Context -> FunPtr InternalSubsetSAXFunc -> IO () + +foreign import ccall "wrapper" + newcb_internalSubset :: InternalSubsetSAXFunc -> IO (FunPtr InternalSubsetSAXFunc) + +-- }}} + +-- warning and error {{{ + +reportWarning :: Callback m (T.Text -> m Bool) +reportWarning = callback wrap_FixedError + getcb_warning + setcb_warning + +reportError :: Callback m (T.Text -> m Bool) +reportError = callback wrap_FixedError + getcb_error + setcb_error + +type FixedErrorFunc = Ptr Context -> CString -> IO () + +wrap_FixedError :: Parser m -> (T.Text -> m Bool) -> IO (FunPtr FixedErrorFunc) +wrap_FixedError p io = + newcb_FixedError $ \ctx cmsg -> + catchRefIO p ctx $ do + msg <- peekUTF8 cmsg + parserToIO p (io msg) + +foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_warning" + getcb_warning :: Ptr Context -> IO (FunPtr FixedErrorFunc) + +foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_error" + getcb_error :: Ptr Context -> IO (FunPtr FixedErrorFunc) + +foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_warning" + setcb_warning :: Ptr Context -> FunPtr FixedErrorFunc -> IO () + +foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_error" + setcb_error :: Ptr Context -> FunPtr FixedErrorFunc -> IO () + +foreign import ccall "wrapper" + newcb_FixedError :: FixedErrorFunc -> IO (FunPtr FixedErrorFunc) + +-- }}} + +-- }}} + +withParserIO :: Parser m -> (Ptr Context -> IO a) -> IO a +withParserIO p io = withForeignPtr (parserHandle p) io + +peekUTF8 :: CString -> IO T.Text +peekUTF8 = fmap (TE.decodeUtf8) . B.packCString + +peekUTF8Len :: CStringLen -> IO T.Text +peekUTF8Len = fmap (TE.decodeUtf8) . B.packCStringLen + +withUTF8 :: T.Text -> (CString -> IO a) -> IO a +withUTF8 = BU.unsafeUseAsCString . TE.encodeUtf8 + +freeFunPtr :: FunPtr a -> IO () +freeFunPtr ptr = if ptr == nullFunPtr + then return () + else freeHaskellFunPtr ptr + +-- mask :: ((forall a. IO a -> IO a) -> IO b) -> IO b +mask :: ((forall a. IO a -> IO a) -> IO b) -> IO b +#if MIN_VERSION_base(4,3,0) +mask = E.mask +#else +mask io = E.block (io E.unblock) +#endif + +foreign import ccall unsafe "hslibxml-shim.h hslibxml_alloc_parser" + cAllocParser :: CString -> IO (Ptr Context) + +foreign import ccall unsafe "hslibxml-shim.h hslibxml_free_parser" + cFreeParser :: Ptr Context -> IO () + +foreign import ccall safe "libxml/parser.h xmlParseChunk" + cParseChunk :: Ptr Context -> CString -> CInt -> CInt -> IO CInt + +foreign import ccall safe "libxml/parser.h xmlStopParser" + cStopParser :: Ptr Context -> IO () + +foreign import ccall unsafe "hslibxml-shim.h hslibxml_want_callback" + cWantCallback :: Ptr Context -> Ptr a -> IO CInt + +-- Unbound callback FFI definitions {{{ + +{- + +data Entity = Entity + +data ParserInput = ParserInput + +data Enumeration = Enumeration + +data ElementContent = ElementContent + +data XmlError = XmlError + +type IsStandaloneSAXFunc = Ptr Context -> IO CInt + +type HasInternalSubsetSAXFunc = Ptr Context -> IO CInt + +type HasExternalSubsetSAXFunc = Ptr Context -> IO CInt + +type ExternalEntityLoader = CString -> CString -> Ptr Context -> IO (Ptr ParserInput) + +type GetEntitySAXFunc = Ptr Context -> CString -> IO (Ptr Entity) + +type EntityDeclSAXFunc = Ptr Context -> CString -> CInt -> CString -> CString -> CString -> IO () + +type NotationDeclSAXFunc = Ptr Context -> CString -> CString -> CString -> IO () + +type AttributeDeclSAXFunc = Ptr Context -> CString -> CString -> CInt -> CInt -> CString -> Ptr Enumeration -> IO () + +type ElementDeclSAXFunc = Ptr Context -> CString -> CInt -> Ptr ElementContent -> IO () + +type UnparsedEntityDeclSAXFunc = Ptr Context -> CString -> CString -> CString -> CString -> IO () + +type GetParameterEntitySAXFunc = Ptr Context -> CString -> IO (Ptr Entity) + +type XmlStructuredErrorFunc = Ptr Context -> Ptr XmlError -> IO () + +foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_isStandalone" + getcb_isStandalone :: Ptr Context -> IO (FunPtr IsStandaloneSAXFunc) + +foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_hasInternalSubset" + getcb_hasInternalSubset :: Ptr Context -> IO (FunPtr HasInternalSubsetSAXFunc) + +foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_hasExternalSubset" + getcb_hasExternalSubset :: Ptr Context -> IO (FunPtr HasExternalSubsetSAXFunc) + +foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_resolveEntity" + getcb_resolveEntity :: Ptr Context -> IO (FunPtr ResolveEntitySAXFunc) + +foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_getEntity" + getcb_getEntity :: Ptr Context -> IO (FunPtr GetEntitySAXFunc) + +foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_entityDecl" + getcb_entityDecl :: Ptr Context -> IO (FunPtr EntityDeclSAXFunc) + +foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_notationDecl" + getcb_notationDecl :: Ptr Context -> IO (FunPtr NotationDeclSAXFunc) + +foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_attributeDecl" + getcb_attributeDecl :: Ptr Context -> IO (FunPtr AttributeDeclSAXFunc) + +foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_elementDecl" + getcb_elementDecl :: Ptr Context -> IO (FunPtr ElementDeclSAXFunc) + +foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_unparsedEntityDecl" + getcb_unparsedEntityDecl :: Ptr Context -> IO (FunPtr UnparsedEntityDeclSAXFunc) + +foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_getParameterEntity" + getcb_getParameterEntity :: Ptr Context -> IO (FunPtr GetParameterEntitySAXFunc) + +foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_serror" + getcb_serror :: Ptr Context -> IO (FunPtr XmlStructuredErrorFunc) + +foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_isStandalone" + setcb_isStandalone :: Ptr Context -> FunPtr IsStandaloneSAXFunc -> IO () + +foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_hasInternalSubset" + setcb_hasInternalSubset :: Ptr Context -> FunPtr HasInternalSubsetSAXFunc -> IO () + +foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_hasExternalSubset" + setcb_hasExternalSubset :: Ptr Context -> FunPtr HasExternalSubsetSAXFunc -> IO () + +foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_resolveEntity" + setcb_resolveEntity :: Ptr Context -> FunPtr ResolveEntitySAXFunc -> IO () + +foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_getEntity" + setcb_getEntity :: Ptr Context -> FunPtr GetEntitySAXFunc -> IO () + +foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_entityDecl" + setcb_entityDecl :: Ptr Context -> FunPtr EntityDeclSAXFunc -> IO () + +foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_notationDecl" + setcb_notationDecl :: Ptr Context -> FunPtr NotationDeclSAXFunc -> IO () + +foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_attributeDecl" + setcb_attributeDecl :: Ptr Context -> FunPtr AttributeDeclSAXFunc -> IO () + +foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_elementDecl" + setcb_elementDecl :: Ptr Context -> FunPtr ElementDeclSAXFunc -> IO () + +foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_unparsedEntityDecl" + setcb_unparsedEntityDecl :: Ptr Context -> FunPtr UnparsedEntityDeclSAXFunc -> IO () + +foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_getParameterEntity" + setcb_getParameterEntity :: Ptr Context -> FunPtr GetParameterEntitySAXFunc -> IO () + +foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_serror" + setcb_serror :: Ptr Context -> FunPtr XmlStructuredErrorFunc -> IO () + +-} + +-- }}} diff --git a/libxml-sax.cabal b/libxml-sax.cabal --- a/libxml-sax.cabal +++ b/libxml-sax.cabal @@ -1,37 +1,47 @@ name: libxml-sax -version: 0.7.2 -synopsis: Bindings for the libXML2 SAX interface +version: 0.7.3 license: MIT license-file: license.txt author: John Millikin maintainer: jmillikin@gmail.com -copyright: Copyright (c) John Millikin 2010 build-type: Simple -cabal-version: >=1.6 +cabal-version: >= 1.6 category: Foreign, Text, XML, Parsing stability: experimental -homepage: http://john-millikin.com/software/bindings/libxml-sax/ -tested-with: GHC==6.12.1 -extra-source-files: hslibxml-shim.h +homepage: https://john-millikin.com/software/haskell-libxml/ +bug-reports: mailto:jmillikin@gmail.com +synopsis: Bindings for the libXML2 SAX interface +description: + +extra-source-files: + cbits/hslibxml-shim.c + cbits/hslibxml-shim.h + source-repository head type: bazaar - location: http://john-millikin.com/software/bindings/libxml-sax/ + location: https://john-millikin.com/branches/haskell-libxml-sax/0.7/ +source-repository this + type: bazaar + location: https://john-millikin.com/branches/haskell-libxml-sax/0.7/ + tag: haskell-libxml-sax_0.7.3 + library + hs-source-dirs: lib ghc-options: -Wall -O2 cc-options: -Wall build-depends: - base >= 4 && < 5 - , bytestring >= 0.9 && < 0.10 + base >= 4.1 && < 5.0 + , bytestring >= 0.9 , text >= 0.7 && < 0.12 , xml-types >= 0.3 && < 0.4 exposed-modules: Text.XML.LibXML.SAX - c-sources: hslibxml-shim.c + c-sources: cbits/hslibxml-shim.c extra-libraries: xml2 pkgconfig-depends: libxml-2.0