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
| ParseError String
deriving (Show, Eq)
data Attribute = Attribute
{ attributeName :: QName
, attributeValue :: String
}
deriving (Show, Eq)
data QName = QName
{ qnameNamespace :: String
, qnamePrefix :: String
, qnameLocalName :: String
}
deriving (Show, Eq)
newtype Parser = Parser (ForeignPtr Context)
data Context = Context
data SAXHandler = SAXHandler
instance Storable SAXHandler where
sizeOf _ = 128
alignment _ = alignment (undefined :: FunPtr ())
peekByteOff = undefined
pokeByteOff handler offset val = return ()
type ContextPtr = Ptr (Context)
type SAXHandlerPtr = Ptr (SAXHandler)
mkParser :: IO Parser
mkParser = let n = nullPtr in do
context <- 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 <- xmlParseChunk ctxt cs (fromIntegral cs_len) cFinal
errors <- checkErrors rc ctxt
events <- readIORef eventRef
return $ reverse 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
(\ptr val -> do {pokeByteOff ptr 108 (val::CUInt)}) handlers xmlSax2Magic
(\ptr val -> do {pokeByteOff ptr 116 (val::(FunPtr ((Ptr ()) -> ((Ptr CUChar) -> ((Ptr CUChar) -> ((Ptr CUChar) -> (CInt -> ((Ptr (Ptr CUChar)) -> (CInt -> (CInt -> ((Ptr (Ptr CUChar)) -> (IO ()))))))))))))}) handlers b
(\ptr val -> do {pokeByteOff ptr 120 (val::(FunPtr ((Ptr ()) -> ((Ptr CUChar) -> ((Ptr CUChar) -> ((Ptr CUChar) -> (IO ())))))))}) handlers e
(\ptr val -> do {pokeByteOff ptr 68 (val::(FunPtr ((Ptr ()) -> ((Ptr CUChar) -> (CInt -> (IO ()))))))}) handlers t
(\ptr val -> do {pokeByteOff ptr 80 (val::(FunPtr ((Ptr ()) -> ((Ptr CUChar) -> (IO ())))))}) handlers c
(\ptr val -> do {pokeByteOff ptr 76 (val::(FunPtr ((Ptr ()) -> ((Ptr CUChar) -> ((Ptr CUChar) -> (IO ()))))))}) handlers pi
block eventRef
setContextHandlers :: Ptr Context -> IO (Ptr SAXHandler)
setContextHandlers ctxt = do
handlers <- calloc 1 128
let handlers' = castPtr handlers
(\ptr val -> do {pokeByteOff ptr 0 (val::(SAXHandlerPtr))}) ctxt handlers'
return handlers'
freeContextHandlers :: Ptr Context -> Ptr SAXHandler -> IO ()
freeContextHandlers ctxt handlers = do
(\ptr val -> do {pokeByteOff ptr 0 (val::(SAXHandlerPtr))}) 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 <- xmlCtxtGetLastError (castPtr ctxt)
message <- peekCString =<< (\ptr -> do {peekByteOff ptr 8 ::IO (Ptr CChar)}) errInfo
return [ParseError message]
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 ((BeginElement (QName ns pfx ln) attrs):es)
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 ((EndElement (QName ns pfx ln)):es)
onCharacters :: IORef [Event] -> CharactersSAXFunc
onCharacters eventref _ ctext ctextlen = do
text <- peekCStringLen (castPtr ctext, fromIntegral ctextlen)
es <- readIORef eventref
writeIORef eventref ((Characters text):es)
onComment :: IORef [Event] -> CommentSAXFunc
onComment eventRef _ ctext = do
text <- peekCString (castPtr ctext)
es <- readIORef eventRef
writeIORef eventRef ((Comment text):es)
onProcessingInstruction :: IORef [Event] -> ProcessingInstructionSAXFunc
onProcessingInstruction eventRef _ ctarget cdata = do
target <- peekCString (castPtr ctarget)
data' <- peekCString (castPtr cdata)
es <- readIORef eventRef
writeIORef eventRef ((ProcessingInstruction target data'):es)
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)
xmlSax2Magic = 0xDEEDBEAF :: CUInt
foreign import ccall safe "Text/XML/LibXML/SAX.chs.h xmlCreatePushParserCtxt"
xmlCreatePushParserCtxt :: ((SAXHandlerPtr) -> ((Ptr ()) -> ((Ptr CChar) -> (CInt -> ((Ptr CChar) -> (IO (ContextPtr)))))))
foreign import ccall safe "Text/XML/LibXML/SAX.chs.h xmlParseChunk"
xmlParseChunk :: ((ContextPtr) -> ((Ptr CChar) -> (CInt -> (CInt -> (IO CInt)))))
foreign import ccall safe "Text/XML/LibXML/SAX.chs.h calloc"
calloc :: (CUInt -> (CUInt -> (IO (Ptr ()))))
foreign import ccall safe "Text/XML/LibXML/SAX.chs.h xmlCtxtGetLastError"
xmlCtxtGetLastError :: ((Ptr ()) -> (IO (Ptr ())))