{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE CPP #-}

-----------------------------------------------------------------------------
-- |
-- Module: Text.XML.LibXML.SAX
-- Copyright: 2010 John Millikin
-- License: MIT
--
-- Maintainer: jmillikin@gmail.com
-- Portability: portable
--
-- Bindings for the libXML2 SAX interface
--
-----------------------------------------------------------------------------

module Text.XML.LibXML.SAX
	(
	-- * Parser
	  Parser
	, newParserIO
	, newParserST
	
	-- ** Parser input
	, parseBytes
	, parseComplete
	
	-- * Callbacks
	, Callback
	, setCallback
	, clearCallback
	
	-- ** Parse events
	, parsedBeginDocument
	, parsedEndDocument
	, parsedBeginElement
	, parsedEndElement
	, parsedCharacters
	, parsedReference
	, parsedComment
	, parsedInstruction
	, parsedCDATA
	, parsedWhitespace
	, parsedInternalSubset
	, parsedExternalSubset
	
	-- ** Warning and error reporting
	, reportWarning
	, reportError
	
	) where

import qualified Control.Exception as E
import           Control.Monad (when, unless)
import qualified Control.Monad.ST as ST

#if MIN_VERSION_base(4,4,0)
import           Control.Monad.ST.Unsafe (unsafeIOToST, unsafeSTToIO)
#else
import           Control.Monad.ST (unsafeIOToST, unsafeSTToIO)
#endif

import qualified Data.ByteString as B
import qualified Data.ByteString.Unsafe as BU
import           Data.Char (chr, isDigit)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.XML.Types as X
import           Data.IORef (IORef, newIORef, readIORef, writeIORef)
import           Foreign hiding (free)
import           Foreign.C
import qualified Foreign.Concurrent as FC
import           Text.ParserCombinators.ReadP ((+++))
import qualified Text.ParserCombinators.ReadP as ReadP

data Context = Context

-- | A 'Parser' tracks the internal state of a LibXML parser context.
--
-- As LibXML is a very stateful library, parsers must operate within either
-- the 'IO' or 'ST.ST' monad. Use 'newParserIO' or 'newParserST' to create
-- parsers in the appropriate monad.
--
-- In general, clients should prefer 'newParserST', because ST values can be
-- safely computed with no side effects.
data Parser m = Parser
	{ parserHandle :: ForeignPtr Context
	, parserErrorRef :: IORef (Maybe E.SomeException)
	, parserToIO :: forall a. m a -> IO a
	, parserFromIO :: forall a. IO a -> m a
	}

newParserIO :: Maybe T.Text -- ^ An optional filename or URI
            -> IO (Parser IO)
newParserIO filename = mask $ \_ -> do
	ref <- newIORef Nothing
	
	raw <- maybeWith withUTF8 filename cAllocParser
	managed <- newForeignPtr_ raw
	
	FC.addForeignPtrFinalizer managed (cFreeParser raw)
	FC.addForeignPtrFinalizer managed (freeCallbacks raw)
	
	return (Parser managed ref id id)

newParserST :: Maybe T.Text -- ^ An optional filename or URI
            -> ST.ST s (Parser (ST.ST s))
newParserST filename = unsafeIOToST $ do
	p <- newParserIO filename
	return $ p
		{ parserToIO = unsafeSTToIO
		, parserFromIO = unsafeIOToST
		}

parseImpl :: Parser m -> (Ptr Context -> IO CInt) -> m ()
parseImpl p io = parserFromIO p $ do
	writeIORef (parserErrorRef p) Nothing
	_ <- mask (\_ -> withParserIO p io)
	
	threw <- readIORef (parserErrorRef p)
	case threw of
		Nothing -> return ()
		Just exc -> E.throwIO exc

parseBytes :: Parser m -> B.ByteString -> m ()
parseBytes p bytes = parseImpl p $ \h ->
	BU.unsafeUseAsCStringLen bytes $ \(cstr, len) ->
	cParseChunk h cstr (fromIntegral len) 0

-- | Finish parsing any buffered data, and check that the document was
-- closed correctly.
-- 
parseComplete :: Parser m -> m ()
parseComplete p = parseImpl p (\h -> cParseComplete h)

-- Callbacks {{{

freeCallbacks :: Ptr Context -> IO ()
freeCallbacks ctx = do
	getcb_startDocument ctx >>= freeFunPtr
	getcb_endDocument ctx >>= freeFunPtr
	getcb_startElementNs ctx >>= freeFunPtr
	getcb_endElementNs ctx >>= freeFunPtr
	getcb_characters ctx >>= freeFunPtr
	getcb_reference ctx >>= freeFunPtr
	getcb_comment ctx >>= freeFunPtr
	getcb_processingInstruction ctx >>= freeFunPtr
	getcb_cdataBlock ctx >>= freeFunPtr
	getcb_ignorableWhitespace ctx >>= freeFunPtr
	getcb_internalSubset ctx >>= freeFunPtr
	getcb_externalSubset ctx >>= freeFunPtr
	getcb_warning ctx >>= freeFunPtr
	getcb_error ctx >>= freeFunPtr

data Callback m a = Callback (Parser m -> a -> IO ()) (Parser m -> IO ())

-- | Set a callback computation to run when a particular parse event occurs.
-- The callback should return 'True' to continue parsing, or 'False'
-- to abort.
--
-- Alternatively, callbacks may throw an 'E.Exception' to abort parsing. The
-- exception will be propagated through to the caller of 'parseBytes' or
-- 'parseComplete'.
setCallback :: Parser m -> Callback m a -> a -> m ()
setCallback p (Callback set _) io = parserFromIO p (set p io)

-- | Remove a callback from the parser. This might also change the parser's
-- behavior, such as automatically expanding entity references when no
-- 'parsedReference' callback is set.
clearCallback :: Parser m -> Callback m a -> m ()
clearCallback p (Callback _ clear) = parserFromIO p (clear p)

catchRef :: Parser m -> Ptr Context -> m Bool -> IO ()
catchRef p cb_ctx io = withParserIO p $ \ctx ->
	(cWantCallback ctx cb_ctx >>=) $ \want ->
	when (want == 1) $ do
		continue <- E.catch (parserToIO p io) $ \e -> do
			writeIORef (parserErrorRef p) (Just e)
			return False
		unless continue (cStopParser ctx)

catchRefIO :: Parser m -> Ptr Context -> IO Bool -> IO ()
catchRefIO p cb_ctx io = catchRef p cb_ctx (parserFromIO p io)

callback :: (Parser m -> a -> IO (FunPtr b))
         -> (Ptr Context -> IO (FunPtr b))
         -> (Ptr Context -> FunPtr b -> IO ())
         -> Callback m a
callback wrap getPtr setPtr = Callback set clear where
	set p io = withForeignPtr (parserHandle p) $ \ctx -> do
		free ctx
		wrap p io >>= setPtr ctx
	clear p = withForeignPtr (parserHandle p) $ \ctx -> do
		free ctx
		setPtr ctx nullFunPtr
	free ctx = getPtr ctx >>= freeFunPtr

-- begin document {{{

parsedBeginDocument :: Callback m (m Bool)
parsedBeginDocument = callback wrap_startDocument
	getcb_startDocument
	setcb_startDocument

type StartDocumentSAXFunc = Ptr Context -> IO ()

wrap_startDocument :: Parser m -> m Bool -> IO (FunPtr StartDocumentSAXFunc)
wrap_startDocument p io = newcb_startDocument (\ctx -> catchRef p ctx io)

foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_startDocument"
	getcb_startDocument :: Ptr Context -> IO (FunPtr StartDocumentSAXFunc)

foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_startDocument"
	setcb_startDocument :: Ptr Context -> FunPtr StartDocumentSAXFunc -> IO ()

foreign import ccall "wrapper"
	newcb_startDocument  :: StartDocumentSAXFunc -> IO (FunPtr StartDocumentSAXFunc)

-- }}}

-- end document {{{

parsedEndDocument :: Callback m (m Bool)
parsedEndDocument = callback wrap_endDocument
	getcb_endDocument
	setcb_endDocument

type EndDocumentSAXFunc = Ptr Context -> IO ()

wrap_endDocument :: Parser m -> m Bool -> IO (FunPtr EndDocumentSAXFunc)
wrap_endDocument p io = newcb_endDocument (\ctx -> catchRef p ctx io)

foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_endDocument"
	getcb_endDocument :: Ptr Context -> IO (FunPtr EndDocumentSAXFunc)

foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_endDocument"
	setcb_endDocument :: Ptr Context -> FunPtr EndDocumentSAXFunc -> IO ()

foreign import ccall "wrapper"
	newcb_endDocument  :: EndDocumentSAXFunc -> IO (FunPtr EndDocumentSAXFunc)

-- }}}

-- begin element {{{

parsedBeginElement :: Callback m (X.Name -> [(X.Name, [X.Content])] -> m Bool)
parsedBeginElement = callback wrap_beginElement
	getcb_startElementNs
	setcb_startElementNs

#if defined(s390x_HOST_ARCH) || defined(ppc64_HOST_ARCH) || defined(sparc64_HOST_ARCH) || defined(x32_HOST_ARCH)
type StartElementNsSAX2Func = (Ptr Context -> CString -> CString -> CString -> Int -> Ptr CString -> Int -> Int -> Ptr CString -> IO ())
#else
type StartElementNsSAX2Func = (Ptr Context -> CString -> CString -> CString -> CInt -> Ptr CString -> CInt -> CInt -> Ptr CString -> IO ())
#endif

wrap_beginElement :: Parser m -> (X.Name -> [(X.Name, [X.Content])] -> m Bool) -> IO (FunPtr StartElementNsSAX2Func)
wrap_beginElement p io =
	newcb_startElementNs $ \ctx cln cpfx cns _ _ n_attrs _ raw_attrs ->
	catchRefIO p ctx $ do
		refCB <- getcb_reference ctx
		let hasRefCB = refCB /= nullFunPtr
		
		ns <- maybePeek peekUTF8 (castPtr cns)
		pfx <- maybePeek peekUTF8 (castPtr cpfx)
		ln <- peekUTF8 (castPtr cln)
		attrs <- peekAttributes hasRefCB (castPtr raw_attrs) n_attrs
		parserToIO p (io (X.Name ln ns pfx) attrs)

foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_startElementNs"
	getcb_startElementNs :: Ptr Context -> IO (FunPtr StartElementNsSAX2Func)

foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_startElementNs"
	setcb_startElementNs :: Ptr Context -> FunPtr StartElementNsSAX2Func -> IO ()

foreign import ccall "wrapper"
	newcb_startElementNs :: StartElementNsSAX2Func -> IO (FunPtr StartElementNsSAX2Func)

#if defined(s390x_HOST_ARCH) || defined(ppc64_HOST_ARCH) || defined(sparc64_HOST_ARCH) || defined(x32_HOST_ARCH)
peekAttributes :: Bool -> Ptr CString -> Int -> IO [(X.Name, [X.Content])]
#else
peekAttributes :: Bool -> Ptr CString -> CInt -> IO [(X.Name, [X.Content])]
#endif
peekAttributes hasRefCB ptr = loop 0 where
	loop _      0 = return []
	loop offset n = do
		local <- peekUTF8 =<< peekElemOff ptr (offset + 0)
		prefix <- maybePeek peekUTF8 =<< peekElemOff ptr (offset + 1)
		ns <- maybePeek peekUTF8 =<< peekElemOff ptr (offset + 2)
		
		val_begin <- peekElemOff ptr (offset + 3)
		val_end <- peekElemOff ptr (offset + 4)
		val <- peekUTF8Len (val_begin, minusPtr val_end val_begin)
		
		let content = if hasRefCB
			then parseAttributeContent val
			else [X.ContentText val]
		let attr = (X.Name local ns prefix, content)
		attrs <- loop (offset + 5) (n - 1)
		
		return (attr:attrs)

parseAttributeContent :: T.Text -> [X.Content]
parseAttributeContent = parse . T.unpack where
	parse chars = case ReadP.readP_to_S parser chars of
		(cs,_):_ -> cs
		_ -> error "parseAttributeContent: no parse"
	parser = ReadP.manyTill content eof
	content = charRef +++ reference +++ text
	charRef = do
		_ <- ReadP.string "&#"
		val <- ReadP.munch1 (isDigit)
		_ <- ReadP.char ';'
		return (X.ContentText (T.singleton (chr (read val))))
	reference = do
		_ <- ReadP.char '&'
		name <- ReadP.munch1 (/= ';')
		_ <- ReadP.char ';'
		return (X.ContentEntity (T.pack name))
	text = do
		chars <- ReadP.munch1 (/= '&')
		return (X.ContentText (T.pack chars))

#if MIN_VERSION_base(4,2,0)
	eof = ReadP.eof
#else
	eof = do
		s <- ReadP.look
		unless (null s) ReadP.pfail
#endif

-- }}}

-- end element {{{

parsedEndElement :: Callback m (X.Name -> m Bool)
parsedEndElement = callback wrap_endElementNs
	getcb_endElementNs
	setcb_endElementNs

type EndElementNsSAX2Func = (Ptr Context -> CString -> CString -> CString -> IO ())

wrap_endElementNs :: Parser m -> (X.Name -> m Bool) -> IO (FunPtr EndElementNsSAX2Func)
wrap_endElementNs p io =
	newcb_endElementNs $ \ctx cln cpfx cns ->
	catchRefIO p ctx $ do
		ns <- maybePeek peekUTF8 (castPtr cns)
		prefix <- maybePeek peekUTF8 (castPtr cpfx)
		local <- peekUTF8 (castPtr cln)
		parserToIO p (io (X.Name local ns prefix))

foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_endElementNs"
	getcb_endElementNs :: Ptr Context -> IO (FunPtr EndElementNsSAX2Func)

foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_endElementNs"
	setcb_endElementNs :: Ptr Context -> FunPtr EndElementNsSAX2Func -> IO ()

foreign import ccall "wrapper"
	newcb_endElementNs :: EndElementNsSAX2Func -> IO (FunPtr EndElementNsSAX2Func)

-- }}}

-- characters, cdata, and whitespace {{{

parsedCharacters :: Callback m (T.Text -> m Bool)
parsedCharacters = callback wrap_characters
	getcb_characters
	setcb_characters

-- | If 'parsedCDATA' is set, it receives any text contained in CDATA
-- blocks. By default, all text is received by 'parsedCharacters'.
parsedCDATA :: Callback m (T.Text -> m Bool)
parsedCDATA = callback wrap_characters
	getcb_cdataBlock
	setcb_cdataBlock

-- | If 'parsedWhitespace' is set, it receives any whitespace marked as
-- ignorable by the document's DTD. By default, all text is received by
-- 'parsedCharacters'.
parsedWhitespace :: Callback m (T.Text -> m Bool)
parsedWhitespace = callback wrap_characters
	getcb_ignorableWhitespace
	setcb_ignorableWhitespace

#if defined(s390x_HOST_ARCH) || defined(ppc64_HOST_ARCH) || defined(sparc64_HOST_ARCH) || defined(x32_HOST_ARCH)
type CharactersSAXFunc = (Ptr Context -> CString -> Int -> IO ())
#else
type CharactersSAXFunc = (Ptr Context -> CString -> CInt -> IO ())
#endif

wrap_characters :: Parser m -> (T.Text -> m Bool) -> IO (FunPtr CharactersSAXFunc)
wrap_characters p io =
	newcb_characters $ \ctx cstr clen ->
	catchRefIO p ctx $ do
		text <- peekUTF8Len (castPtr cstr, fromIntegral clen)
		parserToIO p (io text)

foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_characters"
	getcb_characters :: Ptr Context -> IO (FunPtr CharactersSAXFunc)

foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_cdataBlock"
	getcb_cdataBlock :: Ptr Context -> IO (FunPtr CharactersSAXFunc)

foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_ignorableWhitespace"
	getcb_ignorableWhitespace :: Ptr Context -> IO (FunPtr CharactersSAXFunc)

foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_characters"
	setcb_characters :: Ptr Context -> FunPtr CharactersSAXFunc -> IO ()

foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_cdataBlock"
	setcb_cdataBlock :: Ptr Context -> FunPtr CharactersSAXFunc -> IO ()

foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_ignorableWhitespace"
	setcb_ignorableWhitespace :: Ptr Context -> FunPtr CharactersSAXFunc -> IO ()

foreign import ccall "wrapper"
	newcb_characters :: CharactersSAXFunc -> IO (FunPtr CharactersSAXFunc)

-- }}}

-- entity reference {{{

-- | If 'parsedReference' is set, entity references in element and attribute
-- content will reported separately from text, and will not be automatically
-- expanded.
--
-- Use this when processing documents in passthrough mode, to preserve
-- existing entity references.
parsedReference :: Callback m (T.Text -> m Bool)
parsedReference = callback wrap_reference
	getcb_reference
	setcb_reference

type ReferenceSAXFunc = Ptr Context -> CString -> IO ()

wrap_reference :: Parser m -> (T.Text -> m Bool) -> IO (FunPtr ReferenceSAXFunc)
wrap_reference p io =
	newcb_reference $ \ctx cstr ->
	catchRefIO p ctx $ do
		text <- peekUTF8 (castPtr cstr)
		parserToIO p (io text)

foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_reference"
	getcb_reference :: Ptr Context -> IO (FunPtr ReferenceSAXFunc)

foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_reference"
	setcb_reference :: Ptr Context -> FunPtr ReferenceSAXFunc -> IO ()

foreign import ccall "wrapper"
	newcb_reference :: ReferenceSAXFunc -> IO (FunPtr ReferenceSAXFunc)

-- }}}

-- comment {{{

parsedComment :: Callback m (T.Text -> m Bool)
parsedComment = callback wrap_comment
	getcb_comment
	setcb_comment

type CommentSAXFunc = Ptr Context -> CString -> IO ()

wrap_comment :: Parser m -> (T.Text -> m Bool) -> IO (FunPtr CommentSAXFunc)
wrap_comment p io =
	newcb_comment $ \ctx cstr ->
	catchRefIO p ctx $ do
		text <- peekUTF8 (castPtr cstr)
		parserToIO p (io text)

foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_comment"
	getcb_comment :: Ptr Context -> IO (FunPtr CommentSAXFunc)

foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_comment"
	setcb_comment :: Ptr Context -> FunPtr CommentSAXFunc -> IO ()

foreign import ccall "wrapper"
	newcb_comment :: CommentSAXFunc -> IO (FunPtr CommentSAXFunc)

-- }}}

-- processing instruction {{{

parsedInstruction :: Callback m (X.Instruction -> m Bool)
parsedInstruction = callback wrap_processingInstruction
	getcb_processingInstruction
	setcb_processingInstruction

type ProcessingInstructionSAXFunc = Ptr Context -> CString -> CString -> IO ()

wrap_processingInstruction :: Parser m -> (X.Instruction -> m Bool) -> IO (FunPtr ProcessingInstructionSAXFunc)
wrap_processingInstruction p io =
	newcb_processingInstruction $ \ctx ctarget cdata ->
	catchRefIO p ctx $ do
		target <- peekUTF8 (castPtr ctarget)
		value <- peekUTF8 (castPtr cdata)
		parserToIO p (io (X.Instruction target value))

foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_processingInstruction"
	getcb_processingInstruction :: Ptr Context -> IO (FunPtr ProcessingInstructionSAXFunc)

foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_processingInstruction"
	setcb_processingInstruction :: Ptr Context -> FunPtr ProcessingInstructionSAXFunc -> IO ()

foreign import ccall "wrapper"
	newcb_processingInstruction :: ProcessingInstructionSAXFunc -> IO (FunPtr ProcessingInstructionSAXFunc)

-- }}}

-- external subset {{{

parsedExternalSubset :: Callback m (T.Text -> Maybe X.ExternalID -> m Bool)
parsedExternalSubset = callback wrap_externalSubset
	getcb_externalSubset
	setcb_externalSubset

type ExternalSubsetSAXFunc = Ptr Context -> CString -> CString -> CString -> IO ()

wrap_externalSubset :: Parser m -> (T.Text -> Maybe X.ExternalID -> m Bool) -> IO (FunPtr ExternalSubsetSAXFunc)
wrap_externalSubset p io =
	newcb_externalSubset $ \ctx cname cpublic csystem ->
	catchRefIO p ctx $ do
		name <- peekUTF8 (castPtr cname)
		public <- maybePeek peekUTF8 (castPtr cpublic)
		system <- maybePeek peekUTF8 (castPtr csystem)
		let external = case (public, system) of
			(Nothing, Just s) -> Just (X.SystemID s)
			(Just p', Just s) -> Just (X.PublicID p' s)
			_ -> Nothing
		parserToIO p (io name external)

foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_externalSubset"
	getcb_externalSubset :: Ptr Context -> IO (FunPtr ExternalSubsetSAXFunc)

foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_externalSubset"
	setcb_externalSubset :: Ptr Context -> FunPtr ExternalSubsetSAXFunc -> IO ()

foreign import ccall "wrapper"
	newcb_externalSubset :: ExternalSubsetSAXFunc -> IO (FunPtr ExternalSubsetSAXFunc)

-- }}}

-- internal subset {{{

parsedInternalSubset :: Callback m (T.Text -> Maybe X.ExternalID -> m Bool)
parsedInternalSubset = callback wrap_internalSubset
	getcb_internalSubset
	setcb_internalSubset

type InternalSubsetSAXFunc = Ptr Context -> CString -> CString -> CString -> IO ()

wrap_internalSubset :: Parser m -> (T.Text -> Maybe X.ExternalID -> m Bool) -> IO (FunPtr InternalSubsetSAXFunc)
wrap_internalSubset p io =
	newcb_internalSubset $ \ctx cname cpublic csystem ->
	catchRefIO p ctx $ do
		name <- peekUTF8 (castPtr cname)
		public <- maybePeek peekUTF8 (castPtr cpublic)
		system <- maybePeek peekUTF8 (castPtr csystem)
		let external = case (public, system) of
			(Nothing, Just s) -> Just (X.SystemID s)
			(Just p', Just s) -> Just (X.PublicID p' s)
			_ -> Nothing
		parserToIO p (io name external)

foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_internalSubset"
	getcb_internalSubset :: Ptr Context -> IO (FunPtr InternalSubsetSAXFunc)

foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_internalSubset"
	setcb_internalSubset :: Ptr Context -> FunPtr InternalSubsetSAXFunc -> IO ()

foreign import ccall "wrapper"
	newcb_internalSubset :: InternalSubsetSAXFunc -> IO (FunPtr InternalSubsetSAXFunc)

-- }}}

-- warning and error {{{

reportWarning :: Callback m (T.Text -> m Bool)
reportWarning = callback wrap_FixedError
	getcb_warning
	setcb_warning

reportError :: Callback m (T.Text -> m Bool)
reportError = callback wrap_FixedError
	getcb_error
	setcb_error

type FixedErrorFunc = Ptr Context -> CString -> IO ()

wrap_FixedError :: Parser m -> (T.Text -> m Bool) -> IO (FunPtr FixedErrorFunc)
wrap_FixedError p io =
	newcb_FixedError $ \ctx cmsg ->
	catchRefIO p ctx $ do
		msg <- peekUTF8 cmsg
		parserToIO p (io msg)

foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_warning"
	getcb_warning :: Ptr Context -> IO (FunPtr FixedErrorFunc)

foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_error"
	getcb_error :: Ptr Context -> IO (FunPtr FixedErrorFunc)

foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_warning"
	setcb_warning :: Ptr Context -> FunPtr FixedErrorFunc -> IO ()

foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_error"
	setcb_error :: Ptr Context -> FunPtr FixedErrorFunc -> IO ()

foreign import ccall "wrapper"
	newcb_FixedError :: FixedErrorFunc -> IO (FunPtr FixedErrorFunc)

-- }}}

-- }}}

withParserIO :: Parser m -> (Ptr Context -> IO a) -> IO a
withParserIO p io = withForeignPtr (parserHandle p) io

peekUTF8 :: CString -> IO T.Text
peekUTF8 = fmap (TE.decodeUtf8) . B.packCString

peekUTF8Len :: CStringLen -> IO T.Text
peekUTF8Len = fmap (TE.decodeUtf8) . B.packCStringLen

withUTF8 :: T.Text -> (CString -> IO a) -> IO a
withUTF8 = BU.unsafeUseAsCString . TE.encodeUtf8

freeFunPtr :: FunPtr a -> IO ()
freeFunPtr ptr = if ptr == nullFunPtr
	then return ()
	else freeHaskellFunPtr ptr

-- mask :: ((forall a. IO a -> IO a) -> IO b) -> IO b
mask :: ((forall a. IO a -> IO a) -> IO b) -> IO b
#if MIN_VERSION_base(4,3,0)
mask = E.mask
#else
mask io = E.block (io E.unblock)
#endif

foreign import ccall unsafe "hslibxml-shim.h hslibxml_alloc_parser"
	cAllocParser :: CString -> IO (Ptr Context)

foreign import ccall unsafe "hslibxml-shim.h hslibxml_free_parser"
	cFreeParser :: Ptr Context -> IO ()

foreign import ccall safe "libxml/parser.h xmlParseChunk"
	cParseChunk :: Ptr Context -> CString -> CInt -> CInt -> IO CInt

foreign import ccall safe "hslibxml-shim.h hslibxml_parse_complete"
	cParseComplete :: Ptr Context -> IO CInt

foreign import ccall safe "libxml/parser.h xmlStopParser"
	cStopParser :: Ptr Context -> IO ()

foreign import ccall unsafe "hslibxml-shim.h hslibxml_want_callback"
	cWantCallback :: Ptr Context -> Ptr a -> IO CInt

-- Unbound callback FFI definitions {{{

{-

data Entity = Entity

data ParserInput = ParserInput

data Enumeration = Enumeration

data ElementContent = ElementContent

data XmlError = XmlError

type IsStandaloneSAXFunc = Ptr Context -> IO CInt

type HasInternalSubsetSAXFunc = Ptr Context -> IO CInt

type HasExternalSubsetSAXFunc = Ptr Context -> IO CInt

type ExternalEntityLoader = CString -> CString -> Ptr Context -> IO (Ptr ParserInput)

type GetEntitySAXFunc = Ptr Context -> CString -> IO (Ptr Entity)

type EntityDeclSAXFunc = Ptr Context -> CString -> CInt -> CString -> CString -> CString -> IO ()

type NotationDeclSAXFunc = Ptr Context -> CString -> CString -> CString -> IO ()

type AttributeDeclSAXFunc = Ptr Context -> CString -> CString -> CInt -> CInt -> CString -> Ptr Enumeration -> IO ()

type ElementDeclSAXFunc = Ptr Context -> CString -> CInt -> Ptr ElementContent -> IO ()

type UnparsedEntityDeclSAXFunc = Ptr Context -> CString -> CString -> CString -> CString -> IO ()

type GetParameterEntitySAXFunc = Ptr Context -> CString -> IO (Ptr Entity)

type XmlStructuredErrorFunc = Ptr Context -> Ptr XmlError -> IO ()

foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_isStandalone"
	getcb_isStandalone :: Ptr Context -> IO (FunPtr IsStandaloneSAXFunc)

foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_hasInternalSubset"
	getcb_hasInternalSubset :: Ptr Context -> IO (FunPtr HasInternalSubsetSAXFunc)

foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_hasExternalSubset"
	getcb_hasExternalSubset :: Ptr Context -> IO (FunPtr HasExternalSubsetSAXFunc)

foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_resolveEntity"
	getcb_resolveEntity :: Ptr Context -> IO (FunPtr ResolveEntitySAXFunc)

foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_getEntity"
	getcb_getEntity :: Ptr Context -> IO (FunPtr GetEntitySAXFunc)

foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_entityDecl"
	getcb_entityDecl :: Ptr Context -> IO (FunPtr EntityDeclSAXFunc)

foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_notationDecl"
	getcb_notationDecl :: Ptr Context -> IO (FunPtr NotationDeclSAXFunc)

foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_attributeDecl"
	getcb_attributeDecl :: Ptr Context -> IO (FunPtr AttributeDeclSAXFunc)

foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_elementDecl"
	getcb_elementDecl :: Ptr Context -> IO (FunPtr ElementDeclSAXFunc)

foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_unparsedEntityDecl"
	getcb_unparsedEntityDecl :: Ptr Context -> IO (FunPtr UnparsedEntityDeclSAXFunc)

foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_getParameterEntity"
	getcb_getParameterEntity :: Ptr Context -> IO (FunPtr GetParameterEntitySAXFunc)

foreign import ccall unsafe "hslibxml-shim.h hslibxml_getcb_serror"
	getcb_serror :: Ptr Context -> IO (FunPtr XmlStructuredErrorFunc)

foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_isStandalone"
	setcb_isStandalone :: Ptr Context -> FunPtr IsStandaloneSAXFunc -> IO ()

foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_hasInternalSubset"
	setcb_hasInternalSubset :: Ptr Context -> FunPtr HasInternalSubsetSAXFunc -> IO ()

foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_hasExternalSubset"
	setcb_hasExternalSubset :: Ptr Context -> FunPtr HasExternalSubsetSAXFunc -> IO ()

foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_resolveEntity"
	setcb_resolveEntity :: Ptr Context -> FunPtr ResolveEntitySAXFunc -> IO ()

foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_getEntity"
	setcb_getEntity :: Ptr Context -> FunPtr GetEntitySAXFunc -> IO ()

foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_entityDecl"
	setcb_entityDecl :: Ptr Context -> FunPtr EntityDeclSAXFunc -> IO ()

foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_notationDecl"
	setcb_notationDecl :: Ptr Context -> FunPtr NotationDeclSAXFunc -> IO ()

foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_attributeDecl"
	setcb_attributeDecl :: Ptr Context -> FunPtr AttributeDeclSAXFunc -> IO ()

foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_elementDecl"
	setcb_elementDecl :: Ptr Context -> FunPtr ElementDeclSAXFunc -> IO ()

foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_unparsedEntityDecl"
	setcb_unparsedEntityDecl :: Ptr Context -> FunPtr UnparsedEntityDeclSAXFunc -> IO ()

foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_getParameterEntity"
	setcb_getParameterEntity :: Ptr Context -> FunPtr GetParameterEntitySAXFunc -> IO ()

foreign import ccall unsafe "hslibxml-shim.h hslibxml_setcb_serror"
	setcb_serror :: Ptr Context -> FunPtr XmlStructuredErrorFunc -> IO ()

-}

-- }}}