{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-}

-- | Low-level interface to Expat. Unless speed is paramount, this should
-- normally be avoided in favour of the interfaces provided by
-- 'Text.XML.Expat.SAX' and 'Text.XML.Expat.Tree', etc.  Basic usage is:
--
-- (1) Make a new parser: 'newParser'.
--
-- (2) Set up callbacks on the parser: 'setStartElementHandler', etc.
--
-- (3) Feed data into the parser: 'parse', 'parse'' or 'parseChunk'.  Some of
--     these functions must be wrapped in 'withParser'.

module Text.XML.Expat.Internal.IO (
  -- ** Parser Setup
  Parser, newParser,

  -- ** Parsing
  parse, parse',
  withParser,
  ParserPtr, Parser_struct,
  parseChunk,
  Encoding(..),
  XMLParseError(..),
  getParseLocation,
  XMLParseLocation(..),

  -- ** Parser Callbacks
  XMLDeclarationHandler,
  StartElementHandler,
  EndElementHandler,
  CharacterDataHandler,
  ExternalEntityRefHandler,
  SkippedEntityHandler,
  StartCDataHandler,
  EndCDataHandler,
  CommentHandler,
  ProcessingInstructionHandler,
  setXMLDeclarationHandler,
  setStartElementHandler,
  setEndElementHandler,
  setCharacterDataHandler,
  setStartCDataHandler,
  setEndCDataHandler,
  setProcessingInstructionHandler,
  setCommentHandler,
  setExternalEntityRefHandler,
  setSkippedEntityHandler,
  setUseForeignDTD,

  -- ** Lower-level interface
  parseExternalEntityReference,
  ExpatHandlers,

  -- ** Helpers
  encodingToString
  ) where

import Control.Concurrent
import Control.Exception (bracket)
import Control.DeepSeq
import Control.Monad
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import Data.IORef
import Foreign
import Foreign.C


-- |Opaque parser type.
data Parser_struct
type ParserPtr = Ptr Parser_struct
data Parser = Parser
    { _parserObj                    :: ForeignPtr Parser_struct
    , _xmlDeclarationHandler        :: IORef CXMLDeclarationHandler
    , _startElementHandler          :: IORef CStartElementHandler
    , _endElementHandler            :: IORef CEndElementHandler
    , _cdataHandler                 :: IORef CCharacterDataHandler
    , _externalEntityRefHandler     :: IORef (Maybe CExternalEntityRefHandler)
    , _skippedEntityHandler         :: IORef (Maybe CSkippedEntityHandler)
    , _startCDataHandler            :: IORef CStartCDataHandler
    , _endCDataHandler              :: IORef CEndCDataHandler
    , _processingInstructionHandler :: IORef CProcessingInstructionHandler
    , _commentHandler               :: IORef CCommentHandler
    }

instance Show Parser where
    showsPrec _ (Parser fp _ _ _ _ _ _ _ _ _ _) = showsPrec 0 fp

-- |Encoding types available for the document encoding.
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' -> do
      pp <- parserCreate'_ a1'
      xmlSetUserData pp pp
      return pp

-- | Create a 'Parser'.
newParser :: Maybe Encoding -> IO Parser
newParser enc = do
  ptr          <- parserCreate enc
  fptr         <- newForeignPtr parserFree ptr
  nullXMLDeclH <- newIORef nullCXMLDeclarationHandler
  nullStartH   <- newIORef nullCStartElementHandler
  nullEndH     <- newIORef nullCEndElementHandler
  nullCharH    <- newIORef nullCCharacterDataHandler
  extH         <- newIORef Nothing
  skipH        <- newIORef Nothing
  nullSCDataH  <- newIORef nullCStartCDataHandler
  nullECDataH  <- newIORef nullCEndCDataHandler
  nullPIH      <- newIORef nullCProcessingInstructionHandler
  nullCommentH <- newIORef nullCCommentHandler

  return $ Parser fptr nullXMLDeclH nullStartH nullEndH nullCharH extH skipH 
    nullSCDataH nullECDataH nullPIH nullCommentH
  
setUseForeignDTD :: Parser -> Bool -> IO ()
setUseForeignDTD p b = withParser p $ \p' -> xmlUseForeignDTD p' b'
  where
    b' = if b then 1 else 0

-- ByteString.useAsCStringLen is almost what we need, but C2HS wants a CInt
-- instead of an Int.
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 _ = True

-- |@parse data@ feeds /lazy/ ByteString data into a 'Parser'. It returns
-- Nothing on success, or Just the parse error.
parse :: Parser -> BSL.ByteString -> IO (Maybe XMLParseError)
parse parser bs = withParser parser $ \pp -> do
    let
        doParseChunks [] = doParseChunk pp BS.empty True
        doParseChunks (c:cs) = do
            ok <- doParseChunk pp c False
            if ok
                then doParseChunks cs
                else return False
    ok <- doParseChunks (BSL.toChunks bs)
    if ok
        then return Nothing
        else Just `fmap` getError pp

-- |@parse data@ feeds /strict/ ByteString data into a 'Parser'. It returns
-- Nothing on success, or Just the parse error.
parse' :: Parser -> BS.ByteString -> IO (Maybe XMLParseError)
parse' parser bs = withParser parser $ \pp -> do
    ok <- doParseChunk pp bs True
    if ok
        then return Nothing
        else Just `fmap` getError pp

parseExternalEntityReference :: Parser
                             -> CString         -- ^ context
                             -> Maybe Encoding  -- ^ encoding
                             -> CStringLen      -- ^ text
                             -> IO Bool
parseExternalEntityReference parser context encoding (text,sz) =
    withParser parser $ \pp -> do
        extp <- withOptEncoding encoding $
                xmlExternalEntityParserCreate pp context
        e <- doParseChunk'_ extp text (fromIntegral sz) 1
        parserFree' extp
        return $ e == 1

-- |@parseChunk data False@ feeds /strict/ ByteString data into a
-- 'Parser'.  The end of the data is indicated by passing @True@ for the
-- final parameter.   It returns Nothing on success, or Just the parse error.
parseChunk :: ParserPtr
           -> BS.ByteString
           -> Bool
           -> IO (Maybe XMLParseError)
parseChunk pp xml final = do
    ok <- doParseChunk pp xml final
    if ok
        then return Nothing
        else Just `fmap` getError pp

getError :: ParserPtr -> IO XMLParseError
getError pp = do
    code <- xmlGetErrorCode pp
    cerr <- xmlErrorString code
    err <- peekCString cerr
    loc <- getParseLocation pp
    return $ XMLParseError err loc

data ExpatHandlers = ExpatHandlers
    (FunPtr CXMLDeclarationHandler)
    (FunPtr CStartElementHandler)
    (FunPtr CEndElementHandler)
    (FunPtr CCharacterDataHandler)
    (Maybe (FunPtr CExternalEntityRefHandler))
    (Maybe (FunPtr CSkippedEntityHandler))
    (FunPtr CStartCDataHandler)
    (FunPtr CEndCDataHandler)
    (FunPtr CProcessingInstructionHandler)
    (FunPtr CCommentHandler)

-- | Most of the low-level functions take a ParserPtr so are required to be
-- called inside @withParser@.
withParser :: Parser
           -> (ParserPtr -> IO a)  -- ^ Computation where parseChunk and other low-level functions may be used
           -> IO a
withParser parser@(Parser fp _ _ _ _ _ _ _ _ _ _) code = withForeignPtr fp $ \pp -> do
    bracket
        (unsafeSetHandlers parser pp)
        unsafeReleaseHandlers
        (\_ -> code pp)
  where
    unsafeSetHandlers :: Parser -> ParserPtr -> IO ExpatHandlers
    unsafeSetHandlers (Parser _ xmlDeclRef startRef endRef charRef extRef skipRef 
        startCDataRef endCDataRef processingInstructionRef commentRef) pp =
      do
        cXMLDeclH <- mkCXMLDeclarationHandler =<< readIORef xmlDeclRef
        cStartH <- mkCStartElementHandler =<< readIORef startRef
        cEndH   <- mkCEndElementHandler =<< readIORef endRef
        cCharH  <- mkCCharacterDataHandler =<< readIORef charRef
        mExtH   <- readIORef extRef >>=
                       maybe (return Nothing)
                             (\h -> liftM Just $ mkCExternalEntityRefHandler h)
    
        mSkipH  <- readIORef skipRef >>=
                       maybe (return Nothing)
                             (\h -> liftM Just $ mkCSkippedEntityHandler h)
                             
        cStartCDataH <- mkCStartCDataHandler =<< readIORef startCDataRef
        cEndCDataH   <- mkCEndCDataHandler =<< readIORef endCDataRef
        
        cProcessingInstructionH   <- mkCProcessingInstructionHandler =<< readIORef processingInstructionRef
        cCommentH   <- mkCCommentHandler =<< readIORef commentRef
    
        xmlSetxmldeclhandler       pp cXMLDeclH
        xmlSetstartelementhandler  pp cStartH
        xmlSetendelementhandler    pp cEndH
        xmlSetcharacterdatahandler pp cCharH
        xmlSetstartcdatahandler  pp cStartCDataH
        xmlSetendcdatahandler    pp cEndCDataH
        xmlSetprocessinginstructionhandler pp cProcessingInstructionH
        xmlSetcommenthandler pp cCommentH
        maybe (return ())
              (xmlSetExternalEntityRefHandler pp)
              mExtH
        maybe (return ())
              (xmlSetSkippedEntityHandler pp)
              mSkipH
    
        return $ ExpatHandlers cXMLDeclH cStartH cEndH cCharH mExtH mSkipH 
            cStartCDataH cEndCDataH cProcessingInstructionH cCommentH
    
    unsafeReleaseHandlers :: ExpatHandlers -> IO ()
    unsafeReleaseHandlers (ExpatHandlers cXMLDeclH cStartH cEndH cCharH mcExtH mcSkipH 
            cStartCDataH cEndCDataH cProcessingInstructionH cCommentH) = do
        freeHaskellFunPtr cXMLDeclH
        freeHaskellFunPtr cStartH
        freeHaskellFunPtr cEndH
        freeHaskellFunPtr cCharH
        maybe (return ()) freeHaskellFunPtr mcExtH
        maybe (return ()) freeHaskellFunPtr mcSkipH
        freeHaskellFunPtr cStartCDataH
        freeHaskellFunPtr cEndCDataH
        freeHaskellFunPtr cProcessingInstructionH
        freeHaskellFunPtr cCommentH

-- |Obtain C value from Haskell 'Bool'.
--
cFromBool :: Num a => Bool -> a
cFromBool  = fromBool

doParseChunk :: ParserPtr -> BS.ByteString -> Bool -> IO (Bool)
doParseChunk = ensureBoundThread $ \a1 a2 a3 ->
  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')

data WorkerIface = WorkerIface (MVar (ParserPtr, BS.ByteString, Bool)) (MVar Bool)

workerIfaceRef :: IORef (Maybe WorkerIface)
{-# NOINLINE workerIfaceRef #-}
workerIfaceRef = unsafePerformIO $ newIORef Nothing

-- If the calling thread is not bound, we delegate to a bound thread, because
-- otherwise we get a thread explosion (this is true in ghc-6.12.X).
-- See test/thread-leak/ directory for a test case.
ensureBoundThread :: (ParserPtr -> BS.ByteString -> Bool -> IO Bool)
                  -> ParserPtr
                  -> BS.ByteString
                  -> Bool
                  -> IO Bool
ensureBoundThread doit p bs last = do
    bound <- isCurrentThreadBound
    if rtsSupportsBoundThreads && not bound
        then delegate
        else doit p bs last
  where
    delegate = do
        mIface <- readIORef workerIfaceRef
        case mIface of
            Just iface -> pipeTo iface
            Nothing -> do
                inV <- newEmptyMVar
                outV <- newEmptyMVar
                let iface = WorkerIface inV outV
                justSetItGlobally <- atomicModifyIORef workerIfaceRef $ \mIface ->
                    case mIface of
                        Just _  -> (mIface, False)
                        Nothing -> (Just iface, True) 
                if justSetItGlobally
                    then do
                        _ <- forkOS $ worker iface
                        pipeTo iface
                    else
                        -- If it wasn't changed, then this is because we got a race
                        -- condition with another thread.  We resolve this by trying
                        -- again.  We'll succeed on the second attempt.  The mvars
                        -- we allocated here will be GC'd.
                        delegate

    pipeTo (WorkerIface inV outV) =
        putMVar inV (p, bs, last) >> takeMVar outV

    worker (WorkerIface inV outV) = forever $
        putMVar outV =<< uncurry3 doit =<< takeMVar inV
      where
        uncurry3 f (a, b, c) = f a b c 

-- | Parse error, consisting of message text and error location
data XMLParseError = XMLParseError String XMLParseLocation deriving (Eq, Show)

instance NFData XMLParseError where
    rnf (XMLParseError msg loc) = rnf (msg, loc)

-- | Specifies a location of an event within the input text
data XMLParseLocation = XMLParseLocation {
        xmlLineNumber   :: Int64,  -- ^ Line number of the event
        xmlColumnNumber :: Int64,  -- ^ Column number of the event
        xmlByteIndex    :: Int64,  -- ^ Byte index of event from start of document
        xmlByteCount    :: Int64   -- ^ The number of bytes in the event
    }
    deriving (Eq, Show)

instance NFData XMLParseLocation where
    rnf (XMLParseLocation lin col ind cou) = rnf (lin, col, ind, cou)

getParseLocation :: ParserPtr -> IO XMLParseLocation
getParseLocation pp = do
    line <- xmlGetCurrentLineNumber pp
    col <- xmlGetCurrentColumnNumber pp
    index <- xmlGetCurrentByteIndex pp
    count <- xmlGetCurrentByteCount pp
    return $ XMLParseLocation {
            xmlLineNumber = fromIntegral line,
            xmlColumnNumber = fromIntegral col,
            xmlByteIndex = fromIntegral index,
            xmlByteCount = fromIntegral count
        }

-- | The type of the \"XML declaration\" callback.  Parameters are version,
-- encoding (which can be nullPtr), and standalone declaration, where -1 = no
-- declaration, 0 = "no" and 1 = "yes". Return True to continue parsing as
-- normal, or False to terminate the parse.
type XMLDeclarationHandler = ParserPtr -> CString -> CString -> CInt -> IO Bool

-- | The type of the \"element started\" callback.  The first parameter is the
-- element name; the second are the (attribute, value) pairs. Return True to
-- continue parsing as normal, or False to terminate the parse.
type StartElementHandler  = ParserPtr -> CString -> [(CString, CString)] -> IO Bool

-- | The type of the \"element ended\" callback.  The parameter is the element
-- name. Return True to continue parsing as normal, or False to terminate the
-- parse.
type EndElementHandler    = ParserPtr -> CString -> IO Bool

-- | The type of the \"character data\" callback.  The parameter is the
-- character data processed.  This callback may be called more than once while
-- processing a single conceptual block of text. Return True to continue
-- parsing as normal, or False to terminate the parse.
type CharacterDataHandler = ParserPtr -> CStringLen -> IO Bool

-- | The type of the \"start cdata\" callback.   Return True to continue
-- parsing as normal, or False to terminate the parse.
type StartCDataHandler = ParserPtr -> IO Bool

-- | The type of the \"end cdata\" callback.   Return True to continue
-- parsing as normal, or False to terminate the parse.
type EndCDataHandler = ParserPtr -> IO Bool

-- | The type of the \"processing instruction\" callback.  The first parameter
-- is the first word in the processing instruction.  The second parameter is
-- the rest of the characters in the processing instruction after skipping all
-- whitespace after the initial word. Return True to continue parsing as normal,
-- or False to terminate the parse.
type ProcessingInstructionHandler = ParserPtr -> CString -> CString -> IO Bool

-- | The type of the \"comment\" callback.  The parameter is the comment text.
-- Return True to continue parsing as normal, or False to terminate the parse.
type CommentHandler = ParserPtr -> CString -> IO Bool

-- | The type of the \"external entity reference\" callback. See the expat
-- documentation.
type ExternalEntityRefHandler =  Parser
                              -> CString   -- context
                              -> CString   -- base
                              -> CString   -- systemID
                              -> CString   -- publicID
                              -> IO Bool

-- | Set a skipped entity handler. This is called in two situations:
--
-- 1. An entity reference is encountered for which no declaration has been read
-- and this is not an error.
--
-- 2. An internal entity reference is read, but not expanded, because
-- @XML_SetDefaultHandler@ has been called.
type SkippedEntityHandler =  ParserPtr
                          -> CString   -- entityName
                          -> Int       -- is a parameter entity?
                          -> IO Bool


type CXMLDeclarationHandler = ParserPtr -> CString -> CString -> CInt -> IO ()

nullCXMLDeclarationHandler :: CXMLDeclarationHandler
nullCXMLDeclarationHandler _ _ _ _ = return ()

foreign import ccall safe "wrapper"
  mkCXMLDeclarationHandler :: CXMLDeclarationHandler
                           -> IO (FunPtr CXMLDeclarationHandler)

wrapXMLDeclarationHandler :: Parser -> XMLDeclarationHandler -> CXMLDeclarationHandler
wrapXMLDeclarationHandler parser handler = h
  where
    h pp ver enc sd | ver /= nullPtr = do
        stillRunning <- handler pp ver enc sd
        unless stillRunning $ stopp parser
    {- From expat.h:
       The XML declaration handler is called for *both* XML declarations
       and text declarations. The way to distinguish is that the version
       parameter will be NULL for text declarations.
     -}
    h _ _ _ _ = return ()  -- text declaration (ignore)

-- | Attach a XMLDeclarationHandler to a Parser.
setXMLDeclarationHandler :: Parser -> XMLDeclarationHandler -> IO ()
setXMLDeclarationHandler parser@(Parser _ xmlDeclRef _ _ _ _ _ _ _ _ _) handler =
    writeIORef xmlDeclRef $ wrapXMLDeclarationHandler parser handler


type CStartElementHandler = ParserPtr -> CString -> Ptr CString -> IO ()

nullCStartElementHandler :: CStartElementHandler
nullCStartElementHandler _ _ _ = return ()

foreign import ccall safe "wrapper"
  mkCStartElementHandler :: CStartElementHandler
                         -> IO (FunPtr CStartElementHandler)

wrapStartElementHandler :: Parser -> StartElementHandler -> CStartElementHandler
wrapStartElementHandler parser handler = h
  where
    h pp cname cattrs = do
        cattrlist <- peekArray0 nullPtr cattrs
        stillRunning <- handler pp cname (pairwise cattrlist)
        unless stillRunning $ stopp parser

-- | Attach a StartElementHandler to a Parser.
setStartElementHandler :: Parser -> StartElementHandler -> IO ()
setStartElementHandler parser@(Parser _ _ startRef _ _ _ _ _ _ _ _) handler =
    writeIORef startRef $ wrapStartElementHandler parser handler


type CEndElementHandler = ParserPtr -> CString -> IO ()

nullCEndElementHandler :: CEndElementHandler
nullCEndElementHandler _ _ = return ()

foreign import ccall safe "wrapper"
  mkCEndElementHandler :: CEndElementHandler
                       -> IO (FunPtr CEndElementHandler)
wrapEndElementHandler :: Parser -> EndElementHandler -> CEndElementHandler
wrapEndElementHandler parser handler = h
  where
    h pp cname = do
        stillRunning <- handler pp cname
        unless stillRunning $ stopp parser

-- | Attach an EndElementHandler to a Parser.
setEndElementHandler :: Parser -> EndElementHandler -> IO ()
setEndElementHandler parser@(Parser _ _ _ endRef _ _ _ _ _ _ _) handler =
    writeIORef endRef $ wrapEndElementHandler parser handler


type CCharacterDataHandler = ParserPtr -> CString -> CInt -> IO ()

nullCCharacterDataHandler :: CCharacterDataHandler
nullCCharacterDataHandler _ _ _ = return ()

foreign import ccall safe "wrapper"
  mkCCharacterDataHandler :: CCharacterDataHandler
                          -> IO (FunPtr CCharacterDataHandler)
wrapCharacterDataHandler :: Parser -> CharacterDataHandler -> CCharacterDataHandler
wrapCharacterDataHandler parser handler = h
  where
    h pp cdata len = do
        stillRunning <- handler pp (cdata, fromIntegral len)
        unless stillRunning $ stopp parser

-- | Attach an CharacterDataHandler to a Parser.
setCharacterDataHandler :: Parser -> CharacterDataHandler -> IO ()
setCharacterDataHandler parser@(Parser _ _ _ _ charRef _ _ _ _ _ _) handler =
    writeIORef charRef $ wrapCharacterDataHandler parser handler


type CStartCDataHandler = ParserPtr -> IO ()

nullCStartCDataHandler :: CStartCDataHandler
nullCStartCDataHandler _ = return ()

foreign import ccall safe "wrapper"
  mkCStartCDataHandler :: CStartCDataHandler
                         -> IO (FunPtr CStartCDataHandler)

wrapStartCDataHandler :: Parser -> StartCDataHandler -> CStartCDataHandler
wrapStartCDataHandler parser handler = h
  where
    h pp = do
        stillRunning <- handler pp
        unless stillRunning $ stopp parser

-- | Attach a StartCDataHandler to a Parser.
setStartCDataHandler :: Parser -> StartCDataHandler -> IO ()
setStartCDataHandler parser@(Parser _ _ _ _ _ _ _ startCData _ _ _) handler =
    writeIORef startCData $ wrapStartCDataHandler parser handler


type CEndCDataHandler = ParserPtr -> IO ()

nullCEndCDataHandler :: CEndCDataHandler
nullCEndCDataHandler _ = return ()

foreign import ccall safe "wrapper"
  mkCEndCDataHandler :: CEndCDataHandler
                         -> IO (FunPtr CEndCDataHandler)

wrapEndCDataHandler :: Parser -> EndCDataHandler -> CEndCDataHandler
wrapEndCDataHandler parser handler = h
  where
    h pp = do
        stillRunning <- handler pp
        unless stillRunning $ stopp parser

-- | Attach a EndCDataHandler to a Parser.
setEndCDataHandler :: Parser -> EndCDataHandler -> IO ()
setEndCDataHandler parser@(Parser _ _ _ _ _ _ _ _ endCData _ _) handler =
    writeIORef endCData $ wrapEndCDataHandler parser handler


type CProcessingInstructionHandler = ParserPtr -> CString -> CString -> IO ()

nullCProcessingInstructionHandler :: CProcessingInstructionHandler
nullCProcessingInstructionHandler _ _ _ = return ()

foreign import ccall safe "wrapper"
  mkCProcessingInstructionHandler :: CProcessingInstructionHandler
                          -> IO (FunPtr CProcessingInstructionHandler)
                          
wrapProcessingInstructionHandler :: Parser -> ProcessingInstructionHandler -> CProcessingInstructionHandler
wrapProcessingInstructionHandler parser handler = h
  where
    h pp ctarget cdata = do
        stillRunning <- handler pp ctarget cdata
        unless stillRunning $ stopp parser

-- | Attach a ProcessingInstructionHandler to a Parser.
setProcessingInstructionHandler :: Parser -> ProcessingInstructionHandler -> IO ()
setProcessingInstructionHandler parser@(Parser _ _ _ _ _ _ _ _ _ piRef _) handler =
    writeIORef piRef $ wrapProcessingInstructionHandler parser handler


type CCommentHandler = ParserPtr -> CString -> IO ()

nullCCommentHandler :: CCommentHandler
nullCCommentHandler _ _ = return ()

foreign import ccall safe "wrapper"
  mkCCommentHandler :: CCommentHandler
                          -> IO (FunPtr CCommentHandler)
                          
wrapCommentHandler :: Parser -> CommentHandler -> CCommentHandler
wrapCommentHandler parser handler = h
  where
    h pp cdata = do
        stillRunning <- handler pp cdata
        unless stillRunning $ stopp parser

-- | Attach a CommentHandler to a Parser.
setCommentHandler :: Parser -> CommentHandler -> IO ()
setCommentHandler parser@(Parser _ _ _ _ _ _ _ _ _ _ commentRef) handler =
    writeIORef commentRef $ wrapCommentHandler parser handler


pairwise :: [a] -> [(a,a)]
pairwise (x1:x2:xs) = (x1,x2) : pairwise xs
pairwise _          = []

stopp :: Parser -> IO ()
stopp parser = withParser parser $ \p -> xmlStopParser p 0

------------------------------------------------------------------------------
-- C imports

foreign import ccall unsafe "XML_ParserCreate"
  parserCreate'_ :: Ptr CChar -> IO ParserPtr
  
foreign import ccall unsafe "XML_SetUserData"
  xmlSetUserData :: ParserPtr -> ParserPtr -> IO ()

foreign import ccall unsafe "XML_SetXmlDeclHandler"
  xmlSetxmldeclhandler :: ParserPtr -> FunPtr CXMLDeclarationHandler -> IO ()

foreign import ccall unsafe "XML_SetStartElementHandler"
  xmlSetstartelementhandler :: ParserPtr -> ((FunPtr (ParserPtr -> ((Ptr CChar) -> ((Ptr (Ptr CChar)) -> (IO ())))) -> (IO ())))

foreign import ccall unsafe "XML_SetEndElementHandler"
  xmlSetendelementhandler :: ParserPtr -> ((FunPtr (ParserPtr -> ((Ptr CChar) -> (IO ()))) -> (IO ())))
  
foreign import ccall unsafe "XML_SetCharacterDataHandler"
  xmlSetcharacterdatahandler :: ParserPtr -> ((FunPtr (ParserPtr -> ((Ptr CChar) -> (CInt -> (IO ())))) -> (IO ())))
  
foreign import ccall unsafe "XML_SetStartCdataSectionHandler"
  xmlSetstartcdatahandler :: ParserPtr -> FunPtr CStartCDataHandler -> IO ()

foreign import ccall unsafe "XML_SetEndCdataSectionHandler"
  xmlSetendcdatahandler :: ParserPtr -> FunPtr CStartCDataHandler -> IO ()
  
foreign import ccall unsafe "XML_SetCommentHandler"
  xmlSetcommenthandler :: ParserPtr -> ((FunPtr (ParserPtr -> ((Ptr CChar) -> (IO ()))) -> (IO ())))
  
foreign import ccall unsafe "XML_SetProcessingInstructionHandler"
  xmlSetprocessinginstructionhandler :: ParserPtr -> ((FunPtr (ParserPtr -> ((Ptr CChar) -> ((Ptr CChar) -> (IO ())))) -> (IO ())))

foreign import ccall safe "XML_Parse"
  doParseChunk'_ :: ParserPtr -> ((Ptr CChar) -> (CInt -> (CInt -> (IO CInt))))

foreign import ccall unsafe "XML_UseForeignDTD"
  xmlUseForeignDTD :: ParserPtr     -- ^ parser
                   -> CChar         -- ^ use foreign DTD? (external entity ref
                                    -- handler will be called with publicID &
                                    -- systemID set to null
                   -> IO ()

foreign import ccall "&XML_ParserFree" parserFree :: FunPtr (ParserPtr -> IO ())
foreign import ccall "XML_ParserFree" parserFree' :: ParserPtr -> IO ()

type CExternalEntityRefHandler = ParserPtr   -- parser
                              -> Ptr CChar   -- context
                              -> Ptr CChar   -- base
                              -> Ptr CChar   -- systemID
                              -> Ptr CChar   -- publicID
                              -> IO ()

foreign import ccall unsafe "wrapper"
  mkCExternalEntityRefHandler :: CExternalEntityRefHandler
                              -> IO (FunPtr CExternalEntityRefHandler)


foreign import ccall unsafe "XML_SetExternalEntityRefHandler"
  xmlSetExternalEntityRefHandler :: ParserPtr
                                 -> FunPtr CExternalEntityRefHandler
                                 -> IO ()

foreign import ccall unsafe "XML_SetSkippedEntityHandler"
  xmlSetSkippedEntityHandler :: ParserPtr
                             -> FunPtr CSkippedEntityHandler
                             -> IO ()

foreign import ccall unsafe "XML_ExternalEntityParserCreate"
  xmlExternalEntityParserCreate :: ParserPtr
                                -> CString   -- ^ context
                                -> CString   -- ^ encoding
                                -> IO ParserPtr

type CSkippedEntityHandler =  ParserPtr -- user data pointer
                           -> CString   -- entity name
                           -> CInt      -- is a parameter entity?
                           -> IO ()

foreign import ccall safe "wrapper"
  mkCSkippedEntityHandler :: CSkippedEntityHandler
                          -> IO (FunPtr CSkippedEntityHandler)


wrapExternalEntityRefHandler :: Parser
                             -> ExternalEntityRefHandler
                             -> CExternalEntityRefHandler
wrapExternalEntityRefHandler parser handler = h
  where
    h _ context base systemID publicID = do
        stillRunning <- handler parser context base systemID publicID
        unless stillRunning $ stopp parser


wrapSkippedEntityHandler :: Parser
                         -> SkippedEntityHandler
                         -> CSkippedEntityHandler
wrapSkippedEntityHandler parser handler = h
  where
    h pp entityName i = do
        stillRunning <- handler pp entityName (fromIntegral i)
        unless stillRunning $ stopp parser


setExternalEntityRefHandler :: Parser -> ExternalEntityRefHandler -> IO ()
setExternalEntityRefHandler parser h =
    writeIORef ref $ Just $ wrapExternalEntityRefHandler parser h
  where
    ref = _externalEntityRefHandler parser

setSkippedEntityHandler :: Parser -> SkippedEntityHandler -> IO ()
setSkippedEntityHandler parser h =
    writeIORef ref $ Just $ wrapSkippedEntityHandler parser h
  where
    ref = _skippedEntityHandler parser

-- Note on word sizes:
--
-- on expat 2.0:
-- XML_GetCurrentLineNumber returns XML_Size
-- XML_GetCurrentColumnNumber returns XML_Size
-- XML_GetCurrentByteIndex returns XML_Index
-- These are defined in expat_external.h
--
-- debian-i386 says XML_Size and XML_Index are 4 bytes.
-- ubuntu-amd64 says XML_Size and XML_Index are 8 bytes.
-- These two systems do NOT define XML_LARGE_SIZE, which would force these types
-- to be 64-bit.
--
-- If we guess the word size too small, it shouldn't matter: We will just discard
-- the most significant part.  If we get the word size too large, we will get
-- garbage (very bad).
--
-- So - what I will do is use CLong and CULong, which correspond to what expat
-- is using when XML_LARGE_SIZE is disabled, and give the correct sizes on the
-- two machines mentioned above.  At the absolute worst the word size will be too
-- short.

foreign import ccall unsafe "expat.h XML_GetErrorCode" xmlGetErrorCode
    :: ParserPtr -> IO CInt
foreign import ccall unsafe "expat.h XML_GetCurrentLineNumber" xmlGetCurrentLineNumber
    :: ParserPtr -> IO CULong
foreign import ccall unsafe "expat.h XML_GetCurrentColumnNumber" xmlGetCurrentColumnNumber
    :: ParserPtr -> IO CULong
foreign import ccall unsafe "expat.h XML_GetCurrentByteIndex" xmlGetCurrentByteIndex
    :: ParserPtr -> IO CLong
foreign import ccall unsafe "expat.h XML_GetCurrentByteCount" xmlGetCurrentByteCount
    :: ParserPtr -> IO CInt
foreign import ccall unsafe "expat.h XML_ErrorString" xmlErrorString
    :: CInt -> IO CString
foreign import ccall unsafe "expat.h XML_StopParser" xmlStopParser
    :: ParserPtr -> CInt -> IO ()

