diff --git a/Text/XML/LibXML/SAX.chs b/Text/XML/LibXML/SAX.chs new file mode 100644 --- /dev/null +++ b/Text/XML/LibXML/SAX.chs @@ -0,0 +1,225 @@ +{- Copyright (C) 2009 John Millikin + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . +-} + +{-# LANGUAGE ForeignFunctionInterface #-} + +#include + +module Text.XML.LibXML.SAX ( + Parser + ,Event(..) + ,Attribute(..) + ,QName(..) + ,mkParser + ,parse + ) where + +import Data.IORef (newIORef, readIORef, writeIORef, IORef) +import Foreign +import Foreign.C +import Control.Exception (bracket) + +data Event = + BeginElement QName [Attribute] + | EndElement QName + | Characters String + | Comment String + | ProcessingInstruction String String -- Target, Data + | ParseError String + deriving (Show, Eq) + +data Attribute = Attribute QName String + deriving (Show, Eq) + +-- Namespace, prefix, local name +data QName = QName String String String + deriving (Show, Eq) + +data Parser = Parser (ForeignPtr Context) + +data Context = Context +data SAXHandler = SAXHandler + +instance Storable SAXHandler where + sizeOf _ = {#sizeof xmlSAXHandler #} + alignment _ = alignment (undefined :: FunPtr ()) + peekByteOff = undefined + pokeByteOff handler offset val = return () + +{#pointer *xmlParserCtxt as ContextPtr -> Context #} +{#pointer *xmlSAXHandler as SAXHandlerPtr -> SAXHandler #} +{#pointer *_xmlSAXHandler as SAXHandlerPtr nocode #} + +mkParser :: IO Parser +mkParser = let n = nullPtr in do + context <- {#call xmlCreatePushParserCtxt #} n n n 0 n + autoptr <- newForeignPtr xmlFreeParserCtxt context + return $ Parser autoptr + +foreign import ccall "libxml/parser.h &xmlFreeParserCtxt" + xmlFreeParserCtxt :: FunPtr (Ptr Context -> IO ()) + +parse :: Parser -> String -> Bool -> IO [Event] +parse (Parser fptr) s final = do + withCStringLen s $ \(cs, cs_len) -> do + withForeignPtr fptr $ \ctxt -> do + withHandlers ctxt $ \eventRef -> do + + let cFinal = if final then 1 else 0 + + rc <- {#call xmlParseChunk #} ctxt cs (fromIntegral cs_len) cFinal + errors <- checkErrors rc ctxt + events <- readIORef eventRef + return $ events ++ errors + +withHandlers :: Ptr Context -> (IORef [Event] -> IO a) -> IO a +withHandlers ctxt block = do + eventRef <- newIORef [] + withFunPtr (onBeginElement eventRef) wrappedBegin $ \b -> do + withFunPtr (onEndElement eventRef) wrappedEnd $ \e -> do + withFunPtr (onCharacters eventRef) wrappedText $ \t -> do + withFunPtr (onComment eventRef) wrappedComment $ \c -> do + withFunPtr (onProcessingInstruction eventRef) wrappedProcessingInstruction $ \pi -> do + + bracket + (setContextHandlers ctxt) + (freeContextHandlers ctxt) $ \handlers -> do + + {#set xmlSAXHandler->initialized #} handlers xmlSax2Magic + {#set xmlSAXHandler->startElementNs #} handlers b + {#set xmlSAXHandler->endElementNs #} handlers e + {#set xmlSAXHandler->characters #} handlers t + {#set xmlSAXHandler->comment #} handlers c + {#set xmlSAXHandler->processingInstruction #} handlers pi + + block eventRef + +setContextHandlers :: Ptr Context -> IO (Ptr SAXHandler) +setContextHandlers ctxt = do + handlers <- {#call calloc #} 1 {#sizeof xmlSAXHandler #} + let handlers' = castPtr handlers + {# set xmlParserCtxt->sax #} ctxt handlers' + return handlers' + +freeContextHandlers :: Ptr Context -> Ptr SAXHandler -> IO () +freeContextHandlers ctxt handlers = do + {# set xmlParserCtxt->sax #} ctxt nullPtr + free handlers + +withFunPtr :: a -> (a -> IO (FunPtr a)) -> (FunPtr a -> IO b) -> IO b +withFunPtr f mkPtr block = bracket (mkPtr f) freeHaskellFunPtr block + +checkErrors :: CInt -> Ptr Context -> IO [Event] +checkErrors 0 _ = return [] +checkErrors rc ctxt = do + errInfo <- {#call xmlCtxtGetLastError #} (castPtr ctxt) + message <- peekCString =<< {#get xmlError->message #} errInfo + return [ParseError message] + +-- localname, prefix, namespace, value_begin, value_end +data CAttribute = CAttribute CString CString CString CString CString + +splitCAttributes :: CInt -> Ptr CString -> IO [CAttribute] +splitCAttributes = splitCAttributes' 0 + +splitCAttributes' _ 0 _ = return [] +splitCAttributes' offset n attrs = do + c_ln <- peekElemOff attrs (offset + 0) + c_prefix <- peekElemOff attrs (offset + 1) + c_ns <- peekElemOff attrs (offset + 2) + c_vbegin <- peekElemOff attrs (offset + 3) + c_vend <- peekElemOff attrs (offset + 4) + as <- splitCAttributes' (offset + 5) (n - 1) attrs + return (CAttribute c_ln c_prefix c_ns c_vbegin c_vend : as) + +convertCAttribute :: CAttribute -> IO Attribute +convertCAttribute (CAttribute c_ln c_pfx c_ns c_vbegin c_vend) = do + ln <- peekCString c_ln + pfx <- peekNullable c_pfx + ns <- peekNullable c_ns + val <- peekCStringLen (c_vbegin, minusPtr c_vend c_vbegin) + return (Attribute (QName ns pfx ln) val) + +peekNullable :: CString -> IO String +peekNullable ptr = if ptr == nullPtr then return "" else peekCString ptr + +type CUString = Ptr CUChar + +type StartElementNsSAX2Func = (Ptr () -> CUString -> CUString + -> CUString -> CInt -> Ptr CUString -> CInt + -> CInt -> Ptr CUString -> IO ()) +type EndElementNsSAX2Func = (Ptr () -> CUString -> CUString -> CUString + -> IO ()) +type CharactersSAXFunc = (Ptr () -> CUString -> CInt -> IO ()) + +type CommentSAXFunc = Ptr () -> CUString -> IO () + +type ProcessingInstructionSAXFunc = Ptr () -> CUString -> CUString -> IO () + +onBeginElement :: IORef [Event] -> StartElementNsSAX2Func +onBeginElement eventref _ cln cpfx cns _ _ n_attrs _ raw_attrs = do + ns <- peekNullable $ castPtr cns + pfx <- peekNullable $ castPtr cpfx + ln <- peekCString $ castPtr cln + es <- readIORef eventref + c_attrs <- splitCAttributes n_attrs (castPtr raw_attrs) + attrs <- mapM convertCAttribute c_attrs + writeIORef eventref (es ++ [BeginElement (QName ns pfx ln) attrs]) + +onEndElement :: IORef [Event] -> EndElementNsSAX2Func +onEndElement eventref _ cln cpfx cns = do + ns <- peekNullable $ castPtr cns + pfx <- peekNullable $ castPtr cpfx + ln <- peekCString $ castPtr cln + es <- readIORef eventref + writeIORef eventref (es ++ [EndElement (QName ns pfx ln)]) + +onCharacters :: IORef [Event] -> CharactersSAXFunc +onCharacters eventref _ ctext ctextlen = do + text <- peekCStringLen (castPtr ctext, fromIntegral ctextlen) + es <- readIORef eventref + writeIORef eventref (es ++ [Characters text]) + +onComment :: IORef [Event] -> CommentSAXFunc +onComment eventRef _ ctext = do + text <- peekCString (castPtr ctext) + es <- readIORef eventRef + writeIORef eventRef (es ++ [Comment text]) + +onProcessingInstruction :: IORef [Event] -> ProcessingInstructionSAXFunc +onProcessingInstruction eventRef _ ctarget cdata = do + target <- peekCString (castPtr ctarget) + data' <- peekCString (castPtr cdata) + es <- readIORef eventRef + writeIORef eventRef (es ++ [ProcessingInstruction target data']) + +foreign import ccall "wrapper" + wrappedBegin :: StartElementNsSAX2Func -> IO (FunPtr StartElementNsSAX2Func) + +foreign import ccall "wrapper" + wrappedEnd :: EndElementNsSAX2Func -> IO (FunPtr EndElementNsSAX2Func) + +foreign import ccall "wrapper" + wrappedText :: CharactersSAXFunc -> IO (FunPtr CharactersSAXFunc) + +foreign import ccall "wrapper" + wrappedComment :: CommentSAXFunc -> IO (FunPtr CommentSAXFunc) + +foreign import ccall "wrapper" + wrappedProcessingInstruction :: ProcessingInstructionSAXFunc -> IO (FunPtr ProcessingInstructionSAXFunc) + +-- XML_SAX2_MAGIC +xmlSax2Magic = 0xDEEDBEAF :: CUInt 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,154 +0,0 @@ -{- Copyright (C) 2009 John Millikin - - This program is free software: you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation, either version 3 of the License, or - any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program. If not, see . --} - -{-# LANGUAGE ForeignFunctionInterface #-} -module Text.XML.LibXML.SAX ( - Parser - ,Event(..) - ,Attribute(..) - ,QName(..) - ,newParser - ,incrementalParse - ) where - -import Data.IORef (newIORef, readIORef, writeIORef, IORef) -import qualified Foreign.C as C -import qualified Foreign as F -import Control.Exception (bracket) - -data ParserStruct = ParserStruct -data Parser = Parser !(F.ForeignPtr ParserStruct) - -data Event = - BeginElement QName [Attribute] - | EndElement QName - | Characters String - | ParseError String - deriving (Show, Eq) - -data Attribute = Attribute QName String - deriving (Show, Eq) - --- Namespace, prefix, local name -data QName = QName String String String - deriving (Show, Eq) - -newParser :: IO Parser -newParser = do - ptr <- c_parser_new - autoptr <- F.newForeignPtr c_parser_free ptr - return $ Parser autoptr - -incrementalParse :: Parser -> String -> IO [Event] -incrementalParse (Parser autoptr) s = do - events <- newIORef [] - - C.withCStringLen s $ \(cs, cs_len) -> do - F.withForeignPtr autoptr $ \ptr -> do - withFunPtr (onBeginElement events) wrappedBegin $ \b -> do - withFunPtr (onEndElement events) wrappedEnd $ \e -> do - withFunPtr (onCharacters events) wrappedText $ \t -> do - retval <- (c_parse ptr cs (fromIntegral cs_len) b e t) - (readIORef events) >>= (return . checkReturn retval) - -checkReturn :: C.CInt -> [Event] -> [Event] -checkReturn r es = es ++ case r of - 0 -> [] - _ -> [ParseError (show r)] - -withFunPtr :: a -> (a -> IO (F.FunPtr a)) -> (F.FunPtr a -> IO b) -> IO b -withFunPtr f mkPtr block = bracket (mkPtr f) F.freeHaskellFunPtr block - --- localname, prefix, namespace, value_begin, value_end -data CAttribute = CAttribute C.CString C.CString C.CString C.CString C.CString - -splitCAttributes :: C.CInt -> F.Ptr C.CString -> IO [CAttribute] -splitCAttributes = splitCAttributes' 0 - -splitCAttributes' _ 0 _ = return [] -splitCAttributes' offset n attrs = do - c_ln <- F.peekElemOff attrs (offset + 0) - c_prefix <- F.peekElemOff attrs (offset + 1) - c_ns <- F.peekElemOff attrs (offset + 2) - c_vbegin <- F.peekElemOff attrs (offset + 3) - c_vend <- F.peekElemOff attrs (offset + 4) - as <- splitCAttributes' (offset + 5) (n - 1) attrs - return (CAttribute c_ln c_prefix c_ns c_vbegin c_vend : as) - -convertCAttribute :: CAttribute -> IO Attribute -convertCAttribute (CAttribute c_ln c_pfx c_ns c_vbegin c_vend) = do - ln <- C.peekCString c_ln - pfx <- peekNullable c_pfx - ns <- peekNullable c_ns - val <- C.peekCStringLen (c_vbegin, F.minusPtr c_vend c_vbegin) - return (Attribute (QName ns pfx ln) val) - -peekNullable :: C.CString -> IO String -peekNullable ptr = if ptr == F.nullPtr then return "" else C.peekCString ptr - -type StartElementNsSAX2Func = (F.Ptr () -> C.CString -> C.CString - -> C.CString -> C.CInt -> F.Ptr () -> C.CInt - -> C.CInt -> F.Ptr C.CString -> IO ()) -type EndElementNsSAX2Func = (F.Ptr () -> C.CString -> C.CString -> C.CString - -> IO ()) -type CharactersSAXFunc = (F.Ptr () -> C.CString -> C.CInt -> IO ()) - -onBeginElement :: IORef [Event] -> StartElementNsSAX2Func -onBeginElement eventref _ cln cpfx cns _ _ n_attrs _ raw_attrs = do - ns <- peekNullable cns - pfx <- peekNullable cpfx - ln <- C.peekCString cln - es <- readIORef eventref - c_attrs <- splitCAttributes n_attrs raw_attrs - attrs <- mapM convertCAttribute c_attrs - writeIORef eventref (es ++ [BeginElement (QName ns pfx ln) attrs]) - -onEndElement :: IORef [Event] -> EndElementNsSAX2Func -onEndElement eventref _ cln cpfx cns = do - ns <- peekNullable cns - pfx <- peekNullable cpfx - ln <- C.peekCString cln - es <- readIORef eventref - writeIORef eventref (es ++ [EndElement (QName ns pfx ln)]) - -onCharacters :: IORef [Event] -> CharactersSAXFunc -onCharacters eventref _ ctext ctextlen = do - text <- (C.peekCStringLen (ctext, fromIntegral ctextlen)) - es <- readIORef eventref - writeIORef eventref (es ++ [Characters text]) - -foreign import ccall "wrapper" - wrappedBegin :: StartElementNsSAX2Func -> IO (F.FunPtr StartElementNsSAX2Func) - -foreign import ccall "wrapper" - wrappedEnd :: EndElementNsSAX2Func -> IO (F.FunPtr EndElementNsSAX2Func) - -foreign import ccall "wrapper" - wrappedText :: CharactersSAXFunc -> IO (F.FunPtr CharactersSAXFunc) - -foreign import ccall "incremental-xml.h hs_xml_sax_parser_new" - c_parser_new :: IO (F.Ptr ParserStruct) - -foreign import ccall "incremental-xml.h hs_xml_sax_parse" - c_parse :: F.Ptr ParserStruct -> C.CString -> C.CInt - -> F.FunPtr StartElementNsSAX2Func - -> F.FunPtr EndElementNsSAX2Func - -> F.FunPtr CharactersSAXFunc - -> IO C.CInt - -foreign import ccall "incremental-xml.h &hs_xml_sax_parser_free" - c_parser_free :: F.FunPtr (F.Ptr ParserStruct -> IO ()) - diff --git a/incremental-xml.c b/incremental-xml.c deleted file mode 100644 --- a/incremental-xml.c +++ /dev/null @@ -1,66 +0,0 @@ -/* Copyright (C) 2009 John Millikin - - This program is free software: you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation, either version 3 of the License, or - any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program. If not, see . -*/ - -#include -#include -#include "incremental-xml.h" - -struct _IncrementalParser -{ - xmlSAXHandler handler; - xmlParserCtxt *context; -}; - -IncrementalParser * -hs_xml_sax_parser_new () -{ - IncrementalParser *parser; - parser = malloc (sizeof (IncrementalParser)); - assert (parser != NULL); - - memset (&(parser->handler), 0, sizeof (parser->handler)); - parser->handler.initialized = XML_SAX2_MAGIC; - - parser->context = xmlCreatePushParserCtxt ( - &(parser->handler), parser, NULL, 0, NULL); - assert (parser->context != NULL); - - return parser; -} - -void -hs_xml_sax_parser_free (IncrementalParser *p) -{ - xmlClearParserCtxt (p->context); - xmlFreeParserCtxt (p->context); - free (p); -} - -int -hs_xml_sax_parse ( - IncrementalParser *parser, - const char *text, - int text_len, - startElementNsSAX2Func begin, - endElementNsSAX2Func end, - charactersSAXFunc text_handler) -{ - xmlParserCtxt *c = parser->context; - c->sax->startElementNs = begin; - c->sax->endElementNs = end; - c->sax->characters = text_handler; - return xmlParseChunk (c, text, text_len, 0); -} diff --git a/libxml-sax.cabal b/libxml-sax.cabal --- a/libxml-sax.cabal +++ b/libxml-sax.cabal @@ -1,5 +1,5 @@ Name: libxml-sax -Version: 0.1 +Version: 0.2 Stability: Alpha Synopsis: Bindings for the libXML2 SAX interface Description: Incrementally convert text to lists of XML events @@ -13,10 +13,10 @@ Library Build-Depends: base >=3 && < 5 + build-tools: c2hs Exposed-modules: Text.XML.LibXML.SAX extra-libraries: xml2 pkgconfig-depends: libxml-2.0 - c-sources: incremental-xml.c Extensions: ForeignFunctionInterface