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)
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
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 ())