{-# 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
	{ forall (m :: * -> *). Parser m -> ForeignPtr Context
parserHandle :: ForeignPtr Context
	, forall (m :: * -> *). Parser m -> IORef (Maybe SomeException)
parserErrorRef :: IORef (Maybe E.SomeException)
	, forall (m :: * -> *). Parser m -> forall a. m a -> IO a
parserToIO :: forall a. m a -> IO a
	, forall (m :: * -> *). Parser m -> forall a. IO a -> m a
parserFromIO :: forall a. IO a -> m a
	}

newParserIO :: Maybe T.Text -- ^ An optional filename or URI
            -> IO (Parser IO)
newParserIO :: Maybe Text -> IO (Parser IO)
newParserIO Maybe Text
filename = forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
_ -> do
	IORef (Maybe SomeException)
ref <- forall a. a -> IO (IORef a)
newIORef forall a. Maybe a
Nothing
	
	Ptr Context
raw <- forall a b c.
(a -> (Ptr b -> IO c) -> IO c)
-> Maybe a -> (Ptr b -> IO c) -> IO c
maybeWith forall a. Text -> (CString -> IO a) -> IO a
withUTF8 Maybe Text
filename CString -> IO (Ptr Context)
cAllocParser
	ForeignPtr Context
managed <- forall a. Ptr a -> IO (ForeignPtr a)
newForeignPtr_ Ptr Context
raw
	
	forall a. ForeignPtr a -> IO () -> IO ()
FC.addForeignPtrFinalizer ForeignPtr Context
managed (Ptr Context -> IO ()
cFreeParser Ptr Context
raw)
	forall a. ForeignPtr a -> IO () -> IO ()
FC.addForeignPtrFinalizer ForeignPtr Context
managed (Ptr Context -> IO ()
freeCallbacks Ptr Context
raw)
	
	forall (m :: * -> *) a. Monad m => a -> m a
return (forall (m :: * -> *).
ForeignPtr Context
-> IORef (Maybe SomeException)
-> (forall a. m a -> IO a)
-> (forall a. IO a -> m a)
-> Parser m
Parser ForeignPtr Context
managed IORef (Maybe SomeException)
ref forall a. a -> a
id forall a. a -> a
id)

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

parseImpl :: Parser m -> (Ptr Context -> IO CInt) -> m ()
parseImpl :: forall (m :: * -> *). Parser m -> (Ptr Context -> IO CInt) -> m ()
parseImpl Parser m
p Ptr Context -> IO CInt
io = forall (m :: * -> *). Parser m -> forall a. IO a -> m a
parserFromIO Parser m
p forall a b. (a -> b) -> a -> b
$ do
	forall a. IORef a -> a -> IO ()
writeIORef (forall (m :: * -> *). Parser m -> IORef (Maybe SomeException)
parserErrorRef Parser m
p) forall a. Maybe a
Nothing
	CInt
_ <- forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask (\forall a. IO a -> IO a
_ -> forall (m :: * -> *) a. Parser m -> (Ptr Context -> IO a) -> IO a
withParserIO Parser m
p Ptr Context -> IO CInt
io)
	
	Maybe SomeException
threw <- forall a. IORef a -> IO a
readIORef (forall (m :: * -> *). Parser m -> IORef (Maybe SomeException)
parserErrorRef Parser m
p)
	case Maybe SomeException
threw of
		Maybe SomeException
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
		Just SomeException
exc -> forall e a. Exception e => e -> IO a
E.throwIO SomeException
exc

parseBytes :: Parser m -> B.ByteString -> m ()
parseBytes :: forall (m :: * -> *). Parser m -> ByteString -> m ()
parseBytes Parser m
p ByteString
bytes = forall (m :: * -> *). Parser m -> (Ptr Context -> IO CInt) -> m ()
parseImpl Parser m
p forall a b. (a -> b) -> a -> b
$ \Ptr Context
h ->
	forall a. ByteString -> (CStringLen -> IO a) -> IO a
BU.unsafeUseAsCStringLen ByteString
bytes forall a b. (a -> b) -> a -> b
$ \(CString
cstr, Int
len) ->
	Ptr Context -> CString -> CInt -> CInt -> IO CInt
cParseChunk Ptr Context
h CString
cstr (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len) CInt
0

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

-- Callbacks {{{

freeCallbacks :: Ptr Context -> IO ()
freeCallbacks :: Ptr Context -> IO ()
freeCallbacks Ptr Context
ctx = do
	Ptr Context -> IO (FunPtr (Ptr Context -> IO ()))
getcb_startDocument Ptr Context
ctx forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. FunPtr a -> IO ()
freeFunPtr
	Ptr Context -> IO (FunPtr (Ptr Context -> IO ()))
getcb_endDocument Ptr Context
ctx forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. FunPtr a -> IO ()
freeFunPtr
	Ptr Context -> IO (FunPtr StartElementNsSAX2Func)
getcb_startElementNs Ptr Context
ctx forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. FunPtr a -> IO ()
freeFunPtr
	Ptr Context -> IO (FunPtr EndElementNsSAX2Func)
getcb_endElementNs Ptr Context
ctx forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. FunPtr a -> IO ()
freeFunPtr
	Ptr Context -> IO (FunPtr CharactersSAXFunc)
getcb_characters Ptr Context
ctx forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. FunPtr a -> IO ()
freeFunPtr
	Ptr Context -> IO (FunPtr ReferenceSAXFunc)
getcb_reference Ptr Context
ctx forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. FunPtr a -> IO ()
freeFunPtr
	Ptr Context -> IO (FunPtr ReferenceSAXFunc)
getcb_comment Ptr Context
ctx forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. FunPtr a -> IO ()
freeFunPtr
	Ptr Context -> IO (FunPtr ProcessingInstructionSAXFunc)
getcb_processingInstruction Ptr Context
ctx forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. FunPtr a -> IO ()
freeFunPtr
	Ptr Context -> IO (FunPtr CharactersSAXFunc)
getcb_cdataBlock Ptr Context
ctx forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. FunPtr a -> IO ()
freeFunPtr
	Ptr Context -> IO (FunPtr CharactersSAXFunc)
getcb_ignorableWhitespace Ptr Context
ctx forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. FunPtr a -> IO ()
freeFunPtr
	Ptr Context -> IO (FunPtr EndElementNsSAX2Func)
getcb_internalSubset Ptr Context
ctx forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. FunPtr a -> IO ()
freeFunPtr
	Ptr Context -> IO (FunPtr EndElementNsSAX2Func)
getcb_externalSubset Ptr Context
ctx forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. FunPtr a -> IO ()
freeFunPtr
	Ptr Context -> IO (FunPtr ReferenceSAXFunc)
getcb_warning Ptr Context
ctx forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. FunPtr a -> IO ()
freeFunPtr
	Ptr Context -> IO (FunPtr ReferenceSAXFunc)
getcb_error Ptr Context
ctx forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. FunPtr a -> IO ()
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 :: forall (m :: * -> *) a. Parser m -> Callback m a -> a -> m ()
setCallback Parser m
p (Callback Parser m -> a -> IO ()
set Parser m -> IO ()
_) a
io = forall (m :: * -> *). Parser m -> forall a. IO a -> m a
parserFromIO Parser m
p (Parser m -> a -> IO ()
set Parser m
p a
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 :: forall (m :: * -> *) a. Parser m -> Callback m a -> m ()
clearCallback Parser m
p (Callback Parser m -> a -> IO ()
_ Parser m -> IO ()
clear) = forall (m :: * -> *). Parser m -> forall a. IO a -> m a
parserFromIO Parser m
p (Parser m -> IO ()
clear Parser m
p)

catchRef :: Parser m -> Ptr Context -> m Bool -> IO ()
catchRef :: forall (m :: * -> *). Parser m -> Ptr Context -> m Bool -> IO ()
catchRef Parser m
p Ptr Context
cb_ctx m Bool
io = forall (m :: * -> *) a. Parser m -> (Ptr Context -> IO a) -> IO a
withParserIO Parser m
p forall a b. (a -> b) -> a -> b
$ \Ptr Context
ctx ->
	(forall a. Ptr Context -> Ptr a -> IO CInt
cWantCallback Ptr Context
ctx Ptr Context
cb_ctx forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=) forall a b. (a -> b) -> a -> b
$ \CInt
want ->
	forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
want forall a. Eq a => a -> a -> Bool
== CInt
1) forall a b. (a -> b) -> a -> b
$ do
		Bool
continue <- forall e a. Exception e => IO a -> (e -> IO a) -> IO a
E.catch (forall (m :: * -> *). Parser m -> forall a. m a -> IO a
parserToIO Parser m
p m Bool
io) forall a b. (a -> b) -> a -> b
$ \SomeException
e -> do
			forall a. IORef a -> a -> IO ()
writeIORef (forall (m :: * -> *). Parser m -> IORef (Maybe SomeException)
parserErrorRef Parser m
p) (forall a. a -> Maybe a
Just SomeException
e)
			forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
		forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
continue (Ptr Context -> IO ()
cStopParser Ptr Context
ctx)

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

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

-- begin document {{{

parsedBeginDocument :: Callback m (m Bool)
parsedBeginDocument :: forall (m :: * -> *). Callback m (m Bool)
parsedBeginDocument = forall (m :: * -> *) a b.
(Parser m -> a -> IO (FunPtr b))
-> (Ptr Context -> IO (FunPtr b))
-> (Ptr Context -> FunPtr b -> IO ())
-> Callback m a
callback forall (m :: * -> *).
Parser m -> m Bool -> IO (FunPtr (Ptr Context -> IO ()))
wrap_startDocument
	Ptr Context -> IO (FunPtr (Ptr Context -> IO ()))
getcb_startDocument
	Ptr Context -> FunPtr (Ptr Context -> IO ()) -> IO ()
setcb_startDocument

type StartDocumentSAXFunc = Ptr Context -> IO ()

wrap_startDocument :: Parser m -> m Bool -> IO (FunPtr StartDocumentSAXFunc)
wrap_startDocument :: forall (m :: * -> *).
Parser m -> m Bool -> IO (FunPtr (Ptr Context -> IO ()))
wrap_startDocument Parser m
p m Bool
io = (Ptr Context -> IO ()) -> IO (FunPtr (Ptr Context -> IO ()))
newcb_startDocument (\Ptr Context
ctx -> forall (m :: * -> *). Parser m -> Ptr Context -> m Bool -> IO ()
catchRef Parser m
p Ptr Context
ctx m Bool
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 :: forall (m :: * -> *). Callback m (m Bool)
parsedEndDocument = forall (m :: * -> *) a b.
(Parser m -> a -> IO (FunPtr b))
-> (Ptr Context -> IO (FunPtr b))
-> (Ptr Context -> FunPtr b -> IO ())
-> Callback m a
callback forall (m :: * -> *).
Parser m -> m Bool -> IO (FunPtr (Ptr Context -> IO ()))
wrap_endDocument
	Ptr Context -> IO (FunPtr (Ptr Context -> IO ()))
getcb_endDocument
	Ptr Context -> FunPtr (Ptr Context -> IO ()) -> IO ()
setcb_endDocument

type EndDocumentSAXFunc = Ptr Context -> IO ()

wrap_endDocument :: Parser m -> m Bool -> IO (FunPtr EndDocumentSAXFunc)
wrap_endDocument :: forall (m :: * -> *).
Parser m -> m Bool -> IO (FunPtr (Ptr Context -> IO ()))
wrap_endDocument Parser m
p m Bool
io = (Ptr Context -> IO ()) -> IO (FunPtr (Ptr Context -> IO ()))
newcb_endDocument (\Ptr Context
ctx -> forall (m :: * -> *). Parser m -> Ptr Context -> m Bool -> IO ()
catchRef Parser m
p Ptr Context
ctx m Bool
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 :: forall (m :: * -> *).
Callback m (Name -> [(Name, [Content])] -> m Bool)
parsedBeginElement = forall (m :: * -> *) a b.
(Parser m -> a -> IO (FunPtr b))
-> (Ptr Context -> IO (FunPtr b))
-> (Ptr Context -> FunPtr b -> IO ())
-> Callback m a
callback forall (m :: * -> *).
Parser m
-> (Name -> [(Name, [Content])] -> m Bool)
-> IO (FunPtr StartElementNsSAX2Func)
wrap_beginElement
	Ptr Context -> IO (FunPtr StartElementNsSAX2Func)
getcb_startElementNs
	Ptr Context -> FunPtr StartElementNsSAX2Func -> IO ()
setcb_startElementNs

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

wrap_beginElement :: Parser m -> (X.Name -> [(X.Name, [X.Content])] -> m Bool) -> IO (FunPtr StartElementNsSAX2Func)
wrap_beginElement :: forall (m :: * -> *).
Parser m
-> (Name -> [(Name, [Content])] -> m Bool)
-> IO (FunPtr StartElementNsSAX2Func)
wrap_beginElement Parser m
p Name -> [(Name, [Content])] -> m Bool
io =
	StartElementNsSAX2Func -> IO (FunPtr StartElementNsSAX2Func)
newcb_startElementNs forall a b. (a -> b) -> a -> b
$ \Ptr Context
ctx CString
cln CString
cpfx CString
cns CInt
_ Ptr CString
_ CInt
n_attrs CInt
_ Ptr CString
raw_attrs ->
	forall (m :: * -> *). Parser m -> Ptr Context -> IO Bool -> IO ()
catchRefIO Parser m
p Ptr Context
ctx forall a b. (a -> b) -> a -> b
$ do
		FunPtr ReferenceSAXFunc
refCB <- Ptr Context -> IO (FunPtr ReferenceSAXFunc)
getcb_reference Ptr Context
ctx
		let hasRefCB :: Bool
hasRefCB = FunPtr ReferenceSAXFunc
refCB forall a. Eq a => a -> a -> Bool
/= forall a. FunPtr a
nullFunPtr
		
		Maybe Text
ns <- forall a b. (Ptr a -> IO b) -> Ptr a -> IO (Maybe b)
maybePeek CString -> IO Text
peekUTF8 (forall a b. Ptr a -> Ptr b
castPtr CString
cns)
		Maybe Text
pfx <- forall a b. (Ptr a -> IO b) -> Ptr a -> IO (Maybe b)
maybePeek CString -> IO Text
peekUTF8 (forall a b. Ptr a -> Ptr b
castPtr CString
cpfx)
		Text
ln <- CString -> IO Text
peekUTF8 (forall a b. Ptr a -> Ptr b
castPtr CString
cln)
		[(Name, [Content])]
attrs <- Bool -> Ptr CString -> CInt -> IO [(Name, [Content])]
peekAttributes Bool
hasRefCB (forall a b. Ptr a -> Ptr b
castPtr Ptr CString
raw_attrs) CInt
n_attrs
		forall (m :: * -> *). Parser m -> forall a. m a -> IO a
parserToIO Parser m
p (Name -> [(Name, [Content])] -> m Bool
io (Text -> Maybe Text -> Maybe Text -> Name
X.Name Text
ln Maybe Text
ns Maybe Text
pfx) [(Name, [Content])]
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)

peekAttributes :: Bool -> Ptr CString -> CInt -> IO [(X.Name, [X.Content])]
peekAttributes :: Bool -> Ptr CString -> CInt -> IO [(Name, [Content])]
peekAttributes Bool
hasRefCB Ptr CString
ptr = forall {t}. (Eq t, Num t) => Int -> t -> IO [(Name, [Content])]
loop Int
0 where
	loop :: Int -> t -> IO [(Name, [Content])]
loop Int
_      t
0 = forall (m :: * -> *) a. Monad m => a -> m a
return []
	loop Int
offset t
n = do
		Text
local <- CString -> IO Text
peekUTF8 forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr CString
ptr (Int
offset forall a. Num a => a -> a -> a
+ Int
0)
		Maybe Text
prefix <- forall a b. (Ptr a -> IO b) -> Ptr a -> IO (Maybe b)
maybePeek CString -> IO Text
peekUTF8 forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr CString
ptr (Int
offset forall a. Num a => a -> a -> a
+ Int
1)
		Maybe Text
ns <- forall a b. (Ptr a -> IO b) -> Ptr a -> IO (Maybe b)
maybePeek CString -> IO Text
peekUTF8 forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr CString
ptr (Int
offset forall a. Num a => a -> a -> a
+ Int
2)
		
		CString
val_begin <- forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr CString
ptr (Int
offset forall a. Num a => a -> a -> a
+ Int
3)
		CString
val_end <- forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr CString
ptr (Int
offset forall a. Num a => a -> a -> a
+ Int
4)
		Text
val <- CStringLen -> IO Text
peekUTF8Len (CString
val_begin, forall a b. Ptr a -> Ptr b -> Int
minusPtr CString
val_end CString
val_begin)
		
		let content :: [Content]
content = if Bool
hasRefCB
			then Text -> [Content]
parseAttributeContent Text
val
			else [Text -> Content
X.ContentText Text
val]
		let attr :: (Name, [Content])
attr = (Text -> Maybe Text -> Maybe Text -> Name
X.Name Text
local Maybe Text
ns Maybe Text
prefix, [Content]
content)
		[(Name, [Content])]
attrs <- Int -> t -> IO [(Name, [Content])]
loop (Int
offset forall a. Num a => a -> a -> a
+ Int
5) (t
n forall a. Num a => a -> a -> a
- t
1)
		
		forall (m :: * -> *) a. Monad m => a -> m a
return ((Name, [Content])
attrforall a. a -> [a] -> [a]
:[(Name, [Content])]
attrs)

parseAttributeContent :: T.Text -> [X.Content]
parseAttributeContent :: Text -> [Content]
parseAttributeContent = String -> [Content]
parse forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack where
	parse :: String -> [Content]
parse String
chars = case forall a. ReadP a -> ReadS a
ReadP.readP_to_S ReadP [Content]
parser String
chars of
		([Content]
cs,String
_):[([Content], String)]
_ -> [Content]
cs
		[([Content], String)]
_ -> forall a. HasCallStack => String -> a
error String
"parseAttributeContent: no parse"
	parser :: ReadP [Content]
parser = forall a end. ReadP a -> ReadP end -> ReadP [a]
ReadP.manyTill ReadP Content
content ReadP ()
eof
	content :: ReadP Content
content = ReadP Content
charRef forall a. ReadP a -> ReadP a -> ReadP a
+++ ReadP Content
reference forall a. ReadP a -> ReadP a -> ReadP a
+++ ReadP Content
text
	charRef :: ReadP Content
charRef = do
		String
_ <- String -> ReadP String
ReadP.string String
"&#"
		String
val <- (Char -> Bool) -> ReadP String
ReadP.munch1 (Char -> Bool
isDigit)
		Char
_ <- Char -> ReadP Char
ReadP.char Char
';'
		forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Content
X.ContentText (Char -> Text
T.singleton (Int -> Char
chr (forall a. Read a => String -> a
read String
val))))
	reference :: ReadP Content
reference = do
		Char
_ <- Char -> ReadP Char
ReadP.char Char
'&'
		String
name <- (Char -> Bool) -> ReadP String
ReadP.munch1 (forall a. Eq a => a -> a -> Bool
/= Char
';')
		Char
_ <- Char -> ReadP Char
ReadP.char Char
';'
		forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Content
X.ContentEntity (String -> Text
T.pack String
name))
	text :: ReadP Content
text = do
		String
chars <- (Char -> Bool) -> ReadP String
ReadP.munch1 (forall a. Eq a => a -> a -> Bool
/= Char
'&')
		forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Content
X.ContentText (String -> Text
T.pack String
chars))

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

-- }}}

-- end element {{{

parsedEndElement :: Callback m (X.Name -> m Bool)
parsedEndElement :: forall (m :: * -> *). Callback m (Name -> m Bool)
parsedEndElement = forall (m :: * -> *) a b.
(Parser m -> a -> IO (FunPtr b))
-> (Ptr Context -> IO (FunPtr b))
-> (Ptr Context -> FunPtr b -> IO ())
-> Callback m a
callback forall (m :: * -> *).
Parser m -> (Name -> m Bool) -> IO (FunPtr EndElementNsSAX2Func)
wrap_endElementNs
	Ptr Context -> IO (FunPtr EndElementNsSAX2Func)
getcb_endElementNs
	Ptr Context -> FunPtr EndElementNsSAX2Func -> IO ()
setcb_endElementNs

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

wrap_endElementNs :: Parser m -> (X.Name -> m Bool) -> IO (FunPtr EndElementNsSAX2Func)
wrap_endElementNs :: forall (m :: * -> *).
Parser m -> (Name -> m Bool) -> IO (FunPtr EndElementNsSAX2Func)
wrap_endElementNs Parser m
p Name -> m Bool
io =
	EndElementNsSAX2Func -> IO (FunPtr EndElementNsSAX2Func)
newcb_endElementNs forall a b. (a -> b) -> a -> b
$ \Ptr Context
ctx CString
cln CString
cpfx CString
cns ->
	forall (m :: * -> *). Parser m -> Ptr Context -> IO Bool -> IO ()
catchRefIO Parser m
p Ptr Context
ctx forall a b. (a -> b) -> a -> b
$ do
		Maybe Text
ns <- forall a b. (Ptr a -> IO b) -> Ptr a -> IO (Maybe b)
maybePeek CString -> IO Text
peekUTF8 (forall a b. Ptr a -> Ptr b
castPtr CString
cns)
		Maybe Text
prefix <- forall a b. (Ptr a -> IO b) -> Ptr a -> IO (Maybe b)
maybePeek CString -> IO Text
peekUTF8 (forall a b. Ptr a -> Ptr b
castPtr CString
cpfx)
		Text
local <- CString -> IO Text
peekUTF8 (forall a b. Ptr a -> Ptr b
castPtr CString
cln)
		forall (m :: * -> *). Parser m -> forall a. m a -> IO a
parserToIO Parser m
p (Name -> m Bool
io (Text -> Maybe Text -> Maybe Text -> Name
X.Name Text
local Maybe Text
ns Maybe Text
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 :: forall (m :: * -> *). Callback m (Text -> m Bool)
parsedCharacters = forall (m :: * -> *) a b.
(Parser m -> a -> IO (FunPtr b))
-> (Ptr Context -> IO (FunPtr b))
-> (Ptr Context -> FunPtr b -> IO ())
-> Callback m a
callback forall (m :: * -> *).
Parser m -> (Text -> m Bool) -> IO (FunPtr CharactersSAXFunc)
wrap_characters
	Ptr Context -> IO (FunPtr CharactersSAXFunc)
getcb_characters
	Ptr Context -> FunPtr CharactersSAXFunc -> IO ()
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 :: forall (m :: * -> *). Callback m (Text -> m Bool)
parsedCDATA = forall (m :: * -> *) a b.
(Parser m -> a -> IO (FunPtr b))
-> (Ptr Context -> IO (FunPtr b))
-> (Ptr Context -> FunPtr b -> IO ())
-> Callback m a
callback forall (m :: * -> *).
Parser m -> (Text -> m Bool) -> IO (FunPtr CharactersSAXFunc)
wrap_characters
	Ptr Context -> IO (FunPtr CharactersSAXFunc)
getcb_cdataBlock
	Ptr Context -> FunPtr CharactersSAXFunc -> IO ()
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 :: forall (m :: * -> *). Callback m (Text -> m Bool)
parsedWhitespace = forall (m :: * -> *) a b.
(Parser m -> a -> IO (FunPtr b))
-> (Ptr Context -> IO (FunPtr b))
-> (Ptr Context -> FunPtr b -> IO ())
-> Callback m a
callback forall (m :: * -> *).
Parser m -> (Text -> m Bool) -> IO (FunPtr CharactersSAXFunc)
wrap_characters
	Ptr Context -> IO (FunPtr CharactersSAXFunc)
getcb_ignorableWhitespace
	Ptr Context -> FunPtr CharactersSAXFunc -> IO ()
setcb_ignorableWhitespace

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

wrap_characters :: Parser m -> (T.Text -> m Bool) -> IO (FunPtr CharactersSAXFunc)
wrap_characters :: forall (m :: * -> *).
Parser m -> (Text -> m Bool) -> IO (FunPtr CharactersSAXFunc)
wrap_characters Parser m
p Text -> m Bool
io =
	CharactersSAXFunc -> IO (FunPtr CharactersSAXFunc)
newcb_characters forall a b. (a -> b) -> a -> b
$ \Ptr Context
ctx CString
cstr CInt
clen ->
	forall (m :: * -> *). Parser m -> Ptr Context -> IO Bool -> IO ()
catchRefIO Parser m
p Ptr Context
ctx forall a b. (a -> b) -> a -> b
$ do
		Text
text <- CStringLen -> IO Text
peekUTF8Len (forall a b. Ptr a -> Ptr b
castPtr CString
cstr, forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
clen)
		forall (m :: * -> *). Parser m -> forall a. m a -> IO a
parserToIO Parser m
p (Text -> m Bool
io Text
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 :: forall (m :: * -> *). Callback m (Text -> m Bool)
parsedReference = forall (m :: * -> *) a b.
(Parser m -> a -> IO (FunPtr b))
-> (Ptr Context -> IO (FunPtr b))
-> (Ptr Context -> FunPtr b -> IO ())
-> Callback m a
callback forall (m :: * -> *).
Parser m -> (Text -> m Bool) -> IO (FunPtr ReferenceSAXFunc)
wrap_reference
	Ptr Context -> IO (FunPtr ReferenceSAXFunc)
getcb_reference
	Ptr Context -> FunPtr ReferenceSAXFunc -> IO ()
setcb_reference

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

wrap_reference :: Parser m -> (T.Text -> m Bool) -> IO (FunPtr ReferenceSAXFunc)
wrap_reference :: forall (m :: * -> *).
Parser m -> (Text -> m Bool) -> IO (FunPtr ReferenceSAXFunc)
wrap_reference Parser m
p Text -> m Bool
io =
	ReferenceSAXFunc -> IO (FunPtr ReferenceSAXFunc)
newcb_reference forall a b. (a -> b) -> a -> b
$ \Ptr Context
ctx CString
cstr ->
	forall (m :: * -> *). Parser m -> Ptr Context -> IO Bool -> IO ()
catchRefIO Parser m
p Ptr Context
ctx forall a b. (a -> b) -> a -> b
$ do
		Text
text <- CString -> IO Text
peekUTF8 (forall a b. Ptr a -> Ptr b
castPtr CString
cstr)
		forall (m :: * -> *). Parser m -> forall a. m a -> IO a
parserToIO Parser m
p (Text -> m Bool
io Text
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 :: forall (m :: * -> *). Callback m (Text -> m Bool)
parsedComment = forall (m :: * -> *) a b.
(Parser m -> a -> IO (FunPtr b))
-> (Ptr Context -> IO (FunPtr b))
-> (Ptr Context -> FunPtr b -> IO ())
-> Callback m a
callback forall (m :: * -> *).
Parser m -> (Text -> m Bool) -> IO (FunPtr ReferenceSAXFunc)
wrap_comment
	Ptr Context -> IO (FunPtr ReferenceSAXFunc)
getcb_comment
	Ptr Context -> FunPtr ReferenceSAXFunc -> IO ()
setcb_comment

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

wrap_comment :: Parser m -> (T.Text -> m Bool) -> IO (FunPtr CommentSAXFunc)
wrap_comment :: forall (m :: * -> *).
Parser m -> (Text -> m Bool) -> IO (FunPtr ReferenceSAXFunc)
wrap_comment Parser m
p Text -> m Bool
io =
	ReferenceSAXFunc -> IO (FunPtr ReferenceSAXFunc)
newcb_comment forall a b. (a -> b) -> a -> b
$ \Ptr Context
ctx CString
cstr ->
	forall (m :: * -> *). Parser m -> Ptr Context -> IO Bool -> IO ()
catchRefIO Parser m
p Ptr Context
ctx forall a b. (a -> b) -> a -> b
$ do
		Text
text <- CString -> IO Text
peekUTF8 (forall a b. Ptr a -> Ptr b
castPtr CString
cstr)
		forall (m :: * -> *). Parser m -> forall a. m a -> IO a
parserToIO Parser m
p (Text -> m Bool
io Text
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 :: forall (m :: * -> *). Callback m (Instruction -> m Bool)
parsedInstruction = forall (m :: * -> *) a b.
(Parser m -> a -> IO (FunPtr b))
-> (Ptr Context -> IO (FunPtr b))
-> (Ptr Context -> FunPtr b -> IO ())
-> Callback m a
callback forall (m :: * -> *).
Parser m
-> (Instruction -> m Bool)
-> IO (FunPtr ProcessingInstructionSAXFunc)
wrap_processingInstruction
	Ptr Context -> IO (FunPtr ProcessingInstructionSAXFunc)
getcb_processingInstruction
	Ptr Context -> FunPtr ProcessingInstructionSAXFunc -> IO ()
setcb_processingInstruction

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

wrap_processingInstruction :: Parser m -> (X.Instruction -> m Bool) -> IO (FunPtr ProcessingInstructionSAXFunc)
wrap_processingInstruction :: forall (m :: * -> *).
Parser m
-> (Instruction -> m Bool)
-> IO (FunPtr ProcessingInstructionSAXFunc)
wrap_processingInstruction Parser m
p Instruction -> m Bool
io =
	ProcessingInstructionSAXFunc
-> IO (FunPtr ProcessingInstructionSAXFunc)
newcb_processingInstruction forall a b. (a -> b) -> a -> b
$ \Ptr Context
ctx CString
ctarget CString
cdata ->
	forall (m :: * -> *). Parser m -> Ptr Context -> IO Bool -> IO ()
catchRefIO Parser m
p Ptr Context
ctx forall a b. (a -> b) -> a -> b
$ do
		Text
target <- CString -> IO Text
peekUTF8 (forall a b. Ptr a -> Ptr b
castPtr CString
ctarget)
		Text
value <- CString -> IO Text
peekUTF8 (forall a b. Ptr a -> Ptr b
castPtr CString
cdata)
		forall (m :: * -> *). Parser m -> forall a. m a -> IO a
parserToIO Parser m
p (Instruction -> m Bool
io (Text -> Text -> Instruction
X.Instruction Text
target Text
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 :: forall (m :: * -> *).
Callback m (Text -> Maybe ExternalID -> m Bool)
parsedExternalSubset = forall (m :: * -> *) a b.
(Parser m -> a -> IO (FunPtr b))
-> (Ptr Context -> IO (FunPtr b))
-> (Ptr Context -> FunPtr b -> IO ())
-> Callback m a
callback forall (m :: * -> *).
Parser m
-> (Text -> Maybe ExternalID -> m Bool)
-> IO (FunPtr EndElementNsSAX2Func)
wrap_externalSubset
	Ptr Context -> IO (FunPtr EndElementNsSAX2Func)
getcb_externalSubset
	Ptr Context -> FunPtr EndElementNsSAX2Func -> IO ()
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 :: forall (m :: * -> *).
Parser m
-> (Text -> Maybe ExternalID -> m Bool)
-> IO (FunPtr EndElementNsSAX2Func)
wrap_externalSubset Parser m
p Text -> Maybe ExternalID -> m Bool
io =
	EndElementNsSAX2Func -> IO (FunPtr EndElementNsSAX2Func)
newcb_externalSubset forall a b. (a -> b) -> a -> b
$ \Ptr Context
ctx CString
cname CString
cpublic CString
csystem ->
	forall (m :: * -> *). Parser m -> Ptr Context -> IO Bool -> IO ()
catchRefIO Parser m
p Ptr Context
ctx forall a b. (a -> b) -> a -> b
$ do
		Text
name <- CString -> IO Text
peekUTF8 (forall a b. Ptr a -> Ptr b
castPtr CString
cname)
		Maybe Text
public <- forall a b. (Ptr a -> IO b) -> Ptr a -> IO (Maybe b)
maybePeek CString -> IO Text
peekUTF8 (forall a b. Ptr a -> Ptr b
castPtr CString
cpublic)
		Maybe Text
system <- forall a b. (Ptr a -> IO b) -> Ptr a -> IO (Maybe b)
maybePeek CString -> IO Text
peekUTF8 (forall a b. Ptr a -> Ptr b
castPtr CString
csystem)
		let external :: Maybe ExternalID
external = case (Maybe Text
public, Maybe Text
system) of
			(Maybe Text
Nothing, Just Text
s) -> forall a. a -> Maybe a
Just (Text -> ExternalID
X.SystemID Text
s)
			(Just Text
p', Just Text
s) -> forall a. a -> Maybe a
Just (Text -> Text -> ExternalID
X.PublicID Text
p' Text
s)
			(Maybe Text, Maybe Text)
_ -> forall a. Maybe a
Nothing
		forall (m :: * -> *). Parser m -> forall a. m a -> IO a
parserToIO Parser m
p (Text -> Maybe ExternalID -> m Bool
io Text
name Maybe ExternalID
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 :: forall (m :: * -> *).
Callback m (Text -> Maybe ExternalID -> m Bool)
parsedInternalSubset = forall (m :: * -> *) a b.
(Parser m -> a -> IO (FunPtr b))
-> (Ptr Context -> IO (FunPtr b))
-> (Ptr Context -> FunPtr b -> IO ())
-> Callback m a
callback forall (m :: * -> *).
Parser m
-> (Text -> Maybe ExternalID -> m Bool)
-> IO (FunPtr EndElementNsSAX2Func)
wrap_internalSubset
	Ptr Context -> IO (FunPtr EndElementNsSAX2Func)
getcb_internalSubset
	Ptr Context -> FunPtr EndElementNsSAX2Func -> IO ()
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 :: forall (m :: * -> *).
Parser m
-> (Text -> Maybe ExternalID -> m Bool)
-> IO (FunPtr EndElementNsSAX2Func)
wrap_internalSubset Parser m
p Text -> Maybe ExternalID -> m Bool
io =
	EndElementNsSAX2Func -> IO (FunPtr EndElementNsSAX2Func)
newcb_internalSubset forall a b. (a -> b) -> a -> b
$ \Ptr Context
ctx CString
cname CString
cpublic CString
csystem ->
	forall (m :: * -> *). Parser m -> Ptr Context -> IO Bool -> IO ()
catchRefIO Parser m
p Ptr Context
ctx forall a b. (a -> b) -> a -> b
$ do
		Text
name <- CString -> IO Text
peekUTF8 (forall a b. Ptr a -> Ptr b
castPtr CString
cname)
		Maybe Text
public <- forall a b. (Ptr a -> IO b) -> Ptr a -> IO (Maybe b)
maybePeek CString -> IO Text
peekUTF8 (forall a b. Ptr a -> Ptr b
castPtr CString
cpublic)
		Maybe Text
system <- forall a b. (Ptr a -> IO b) -> Ptr a -> IO (Maybe b)
maybePeek CString -> IO Text
peekUTF8 (forall a b. Ptr a -> Ptr b
castPtr CString
csystem)
		let external :: Maybe ExternalID
external = case (Maybe Text
public, Maybe Text
system) of
			(Maybe Text
Nothing, Just Text
s) -> forall a. a -> Maybe a
Just (Text -> ExternalID
X.SystemID Text
s)
			(Just Text
p', Just Text
s) -> forall a. a -> Maybe a
Just (Text -> Text -> ExternalID
X.PublicID Text
p' Text
s)
			(Maybe Text, Maybe Text)
_ -> forall a. Maybe a
Nothing
		forall (m :: * -> *). Parser m -> forall a. m a -> IO a
parserToIO Parser m
p (Text -> Maybe ExternalID -> m Bool
io Text
name Maybe ExternalID
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 :: forall (m :: * -> *). Callback m (Text -> m Bool)
reportWarning = forall (m :: * -> *) a b.
(Parser m -> a -> IO (FunPtr b))
-> (Ptr Context -> IO (FunPtr b))
-> (Ptr Context -> FunPtr b -> IO ())
-> Callback m a
callback forall (m :: * -> *).
Parser m -> (Text -> m Bool) -> IO (FunPtr ReferenceSAXFunc)
wrap_FixedError
	Ptr Context -> IO (FunPtr ReferenceSAXFunc)
getcb_warning
	Ptr Context -> FunPtr ReferenceSAXFunc -> IO ()
setcb_warning

reportError :: Callback m (T.Text -> m Bool)
reportError :: forall (m :: * -> *). Callback m (Text -> m Bool)
reportError = forall (m :: * -> *) a b.
(Parser m -> a -> IO (FunPtr b))
-> (Ptr Context -> IO (FunPtr b))
-> (Ptr Context -> FunPtr b -> IO ())
-> Callback m a
callback forall (m :: * -> *).
Parser m -> (Text -> m Bool) -> IO (FunPtr ReferenceSAXFunc)
wrap_FixedError
	Ptr Context -> IO (FunPtr ReferenceSAXFunc)
getcb_error
	Ptr Context -> FunPtr ReferenceSAXFunc -> IO ()
setcb_error

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

wrap_FixedError :: Parser m -> (T.Text -> m Bool) -> IO (FunPtr FixedErrorFunc)
wrap_FixedError :: forall (m :: * -> *).
Parser m -> (Text -> m Bool) -> IO (FunPtr ReferenceSAXFunc)
wrap_FixedError Parser m
p Text -> m Bool
io =
	ReferenceSAXFunc -> IO (FunPtr ReferenceSAXFunc)
newcb_FixedError forall a b. (a -> b) -> a -> b
$ \Ptr Context
ctx CString
cmsg ->
	forall (m :: * -> *). Parser m -> Ptr Context -> IO Bool -> IO ()
catchRefIO Parser m
p Ptr Context
ctx forall a b. (a -> b) -> a -> b
$ do
		Text
msg <- CString -> IO Text
peekUTF8 CString
cmsg
		forall (m :: * -> *). Parser m -> forall a. m a -> IO a
parserToIO Parser m
p (Text -> m Bool
io Text
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 :: forall (m :: * -> *) a. Parser m -> (Ptr Context -> IO a) -> IO a
withParserIO Parser m
p Ptr Context -> IO a
io = forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr (forall (m :: * -> *). Parser m -> ForeignPtr Context
parserHandle Parser m
p) Ptr Context -> IO a
io

peekUTF8 :: CString -> IO T.Text
peekUTF8 :: CString -> IO Text
peekUTF8 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString -> Text
TE.decodeUtf8) forall b c a. (b -> c) -> (a -> b) -> a -> c
. CString -> IO ByteString
B.packCString

peekUTF8Len :: CStringLen -> IO T.Text
peekUTF8Len :: CStringLen -> IO Text
peekUTF8Len = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString -> Text
TE.decodeUtf8) forall b c a. (b -> c) -> (a -> b) -> a -> c
. CStringLen -> IO ByteString
B.packCStringLen

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

freeFunPtr :: FunPtr a -> IO ()
freeFunPtr :: forall a. FunPtr a -> IO ()
freeFunPtr FunPtr a
ptr = if FunPtr a
ptr forall a. Eq a => a -> a -> Bool
== forall a. FunPtr a
nullFunPtr
	then forall (m :: * -> *) a. Monad m => a -> m a
return ()
	else forall a. FunPtr a -> IO ()
freeHaskellFunPtr FunPtr a
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 :: forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask = forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
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 ()

-}

-- }}}