module Text.XML.Expat.IO (
Parser, newParser,
parse, Encoding(..),
StartElementHandler, EndElementHandler, CharacterDataHandler,
setStartElementHandler, setEndElementHandler, setCharacterDataHandler,
parseChunk,
encodingToString
) where
import Control.Exception (bracket)
import C2HS
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import Data.IORef
type ParserPtr = Ptr ()
data Parser = Parser
(ForeignPtr ())
(IORef CStartElementHandler)
(IORef CEndElementHandler)
(IORef CCharacterDataHandler)
withParser :: Parser -> (ParserPtr -> IO a) -> IO a
withParser (Parser fp _ _ _) = withForeignPtr fp
data Encoding = ASCII | UTF8 | UTF16 | ISO88591
encodingToString :: Encoding -> String
encodingToString ASCII = "US-ASCII"
encodingToString UTF8 = "UTF-8"
encodingToString UTF16 = "UTF-16"
encodingToString ISO88591 = "ISO-8859-1"
withOptEncoding :: Maybe Encoding -> (CString -> IO a) -> IO a
withOptEncoding Nothing f = f nullPtr
withOptEncoding (Just enc) f = withCString (encodingToString enc) f
parserCreate :: Maybe Encoding -> IO (ParserPtr)
parserCreate a1 =
withOptEncoding a1 $ \a1' ->
parserCreate'_ a1' >>= \res ->
let {res' = id res} in
return (res')
foreign import ccall "&XML_ParserFree" parserFree :: FunPtr (ParserPtr -> IO ())
newParser :: Maybe Encoding -> IO Parser
newParser enc = do
ptr <- parserCreate enc
fptr <- newForeignPtr parserFree ptr
nullStartH <- newIORef nullCStartElementHandler
nullEndH <- newIORef nullCEndElementHandler
nullCharH <- newIORef nullCCharacterDataHandler
return $ Parser fptr nullStartH nullEndH nullCharH
withBStringLen :: BS.ByteString -> ((CString, CInt) -> IO a) -> IO a
withBStringLen bs f = do
BS.useAsCStringLen bs $ \(str, len) -> f (str, fromIntegral len)
unStatus :: CInt -> Bool
unStatus 0 = False
unStatus 1 = True
parseChunk :: Parser
-> BS.ByteString
-> Bool
-> IO Bool
parseChunk parser@(Parser fp startRef endRef charRef) xml final = do
bracket
(do
cStartH <- mkCStartElementHandler =<< readIORef startRef
cEndH <- mkCEndElementHandler =<< readIORef endRef
cCharH <- mkCCharacterDataHandler =<< readIORef charRef
withParser parser $ \p -> do
xMLSetStartElementHandler p cStartH
xMLSetEndElementHandler p cEndH
xMLSetCharacterDataHandler p cCharH
return (cStartH, cEndH, cCharH))
(\(cStartH, cEndH, cCharH) -> do
freeHaskellFunPtr cStartH
freeHaskellFunPtr cEndH
freeHaskellFunPtr cCharH)
(\_ -> doParseChunk parser xml final)
doParseChunk :: Parser -> BS.ByteString -> Bool -> IO (Bool)
doParseChunk a1 a2 a3 =
withParser a1 $ \a1' ->
withBStringLen a2 $ \(a2'1, a2'2) ->
let {a3' = cFromBool a3} in
doParseChunk'_ a1' a2'1 a2'2 a3' >>= \res ->
let {res' = unStatus res} in
return (res')
parse :: Parser -> BSL.ByteString -> IO Bool
parse parser bs = feedChunk (BSL.toChunks bs) where
feedChunk [] = return True
feedChunk [chunk] = parseChunk parser chunk True
feedChunk (c:cs) = do ok <- parseChunk parser c False
if ok then feedChunk cs
else return False
type StartElementHandler = String -> [(String,String)] -> IO ()
type EndElementHandler = String -> IO ()
type CharacterDataHandler = String -> IO ()
type CStartElementHandler = Ptr () -> CString -> Ptr CString -> IO ()
nullCStartElementHandler _ _ _ = return ()
foreign import ccall "wrapper"
mkCStartElementHandler :: CStartElementHandler
-> IO (FunPtr CStartElementHandler)
wrapStartElementHandler :: StartElementHandler -> CStartElementHandler
wrapStartElementHandler handler = h where
h ptr cname cattrs = do
name <- peekCString cname
cattrlist <- peekArray0 nullPtr cattrs
attrlist <- mapM peekCString cattrlist
handler name (pairwise attrlist)
setStartElementHandler :: Parser -> StartElementHandler -> IO ()
setStartElementHandler parser@(Parser _ startRef _ _) handler = do
withParser parser $ \p -> do
writeIORef startRef $ wrapStartElementHandler handler
type CEndElementHandler = Ptr () -> CString -> IO ()
nullCEndElementHandler _ _ = return ()
foreign import ccall "wrapper"
mkCEndElementHandler :: CEndElementHandler
-> IO (FunPtr CEndElementHandler)
wrapEndElementHandler :: EndElementHandler -> CEndElementHandler
wrapEndElementHandler handler = h where
h ptr cname = do
name <- peekCString cname
handler name
setEndElementHandler :: Parser -> EndElementHandler -> IO ()
setEndElementHandler parser@(Parser _ _ endRef _) handler = do
withParser parser $ \p -> do
writeIORef endRef $ wrapEndElementHandler handler
type CCharacterDataHandler = Ptr () -> CString -> CInt -> IO ()
nullCCharacterDataHandler _ _ _ = return ()
foreign import ccall "wrapper"
mkCCharacterDataHandler :: CCharacterDataHandler
-> IO (FunPtr CCharacterDataHandler)
wrapCharacterDataHandler :: CharacterDataHandler -> CCharacterDataHandler
wrapCharacterDataHandler handler = h where
h ptr cdata len = do
data_ <- peekCStringLen (cdata, fromIntegral len)
handler data_
setCharacterDataHandler :: Parser -> CharacterDataHandler -> IO ()
setCharacterDataHandler parser@(Parser _ _ _ charRef) handler = do
withParser parser $ \p -> do
writeIORef charRef $ wrapCharacterDataHandler handler
pairwise (x1:x2:xs) = (x1,x2) : pairwise xs
pairwise [] = []
foreign import ccall unsafe "Text/XML/Expat/IO.chs.h XML_ParserCreate"
parserCreate'_ :: ((Ptr CChar) -> (IO (Ptr ())))
foreign import ccall unsafe "Text/XML/Expat/IO.chs.h XML_SetStartElementHandler"
xMLSetStartElementHandler :: ((Ptr ()) -> ((FunPtr ((Ptr ()) -> ((Ptr CChar) -> ((Ptr (Ptr CChar)) -> (IO ()))))) -> (IO ())))
foreign import ccall unsafe "Text/XML/Expat/IO.chs.h XML_SetEndElementHandler"
xMLSetEndElementHandler :: ((Ptr ()) -> ((FunPtr ((Ptr ()) -> ((Ptr CChar) -> (IO ())))) -> (IO ())))
foreign import ccall unsafe "Text/XML/Expat/IO.chs.h XML_SetCharacterDataHandler"
xMLSetCharacterDataHandler :: ((Ptr ()) -> ((FunPtr ((Ptr ()) -> ((Ptr CChar) -> (CInt -> (IO ()))))) -> (IO ())))
foreign import ccall safe "Text/XML/Expat/IO.chs.h XML_Parse"
doParseChunk'_ :: ((Ptr ()) -> ((Ptr CChar) -> (CInt -> (CInt -> (IO CInt)))))