-- GENERATED by C->Haskell Compiler, version 0.16.0 Crystal Seed, 24 Jan 2009 (Haskell)
-- Edit the ORIGNAL .chs file instead!


{-# LINE 1 "./Text/XML/LibXML/SAX.chs" #-}{- Copyright (C) 2009 John Millikin <jmillikin@gmail.com>
   
   This program is free software: you can redistribute it and/or modify
   it under the terms of the GNU General Public License as published by
   the Free Software Foundation, either version 3 of the License, or
   any later version.
   
   This program is distributed in the hope that it will be useful,
   but WITHOUT ANY WARRANTY; without even the implied warranty of
   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   GNU General Public License for more details.
   
   You should have received a copy of the GNU General Public License
   along with this program.  If not, see <http://www.gnu.org/licenses/>.
-}

{-# LANGUAGE ForeignFunctionInterface #-}


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 -- ^ Target, Data
	| 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)

-- | An opaque reference to a libXML SAX parser.
-- 
newtype Parser = Parser (ForeignPtr Context)

data Context = Context
data SAXHandler = SAXHandler

instance Storable SAXHandler where
	sizeOf _ = 128
{-# LINE 65 "./Text/XML/LibXML/SAX.chs" #-}
	alignment _ = alignment (undefined :: FunPtr ())
	peekByteOff = undefined
	pokeByteOff handler offset val = return ()

type ContextPtr = Ptr (Context)
{-# LINE 70 "./Text/XML/LibXML/SAX.chs" #-}
type SAXHandlerPtr = Ptr (SAXHandler)
{-# LINE 71 "./Text/XML/LibXML/SAX.chs" #-}

{-# LINE 72 "./Text/XML/LibXML/SAX.chs" #-}

-- | Construct a new, empty parser.
-- 
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 ())

-- | Feed some text into the parser. This may be performed multiple times
-- per 'Parser' value, in which case the internal parser state is retained
-- between computations.
-- 
-- If the third parameter is 'True', the parser assumes that this is the
-- last input and checks that the document was closed correctly.
-- 
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
{-# LINE 129 "./Text/XML/LibXML/SAX.chs" #-}
	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]

-- localname, prefix, namespace, value_begin, value_end
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)

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