libxml-sax 0.1 → 0.2

raw patch · 4 files changed

+227/−222 lines, 4 filesdep ~basePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• Text/XML/LibXML/SAX.chs +225/−0
• Text/XML/LibXML/SAX.hs +0/−154
• incremental-xml.c +0/−66
• libxml-sax.cabal +2/−2

@@ -0,0 +1,225 @@+{- Copyright (C) 2009 John Millikin <jmillikin@gmail.com>+   +   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 <http://www.gnu.org/licenses/>.+-}++{-# LANGUAGE ForeignFunctionInterface #-}++#include <libxml/parser.h>++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

@@ -1,154 +0,0 @@-{- Copyright (C) 2009 John Millikin <jmillikin@gmail.com>-   -   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 <http://www.gnu.org/licenses/>.--}--{-# 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 ())-

@@ -1,66 +0,0 @@-/* Copyright (C) 2009 John Millikin <jmillikin@gmail.com>-   -   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 <http://www.gnu.org/licenses/>.-*/--#include <string.h>-#include <assert.h>-#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);-}

@@ -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