HexpatInternal.hs

{-
Under BSD 3-Clause license, (c) 2009 Doug Beardsley <mightybyte@gmail.com>, (c) 2009-2012 Stephen Blackheath <http://blacksapphire.com/antispam/>, (c) 2009 Gregory Collins, (c) 2008 Evan Martin <martine@danga.com>, (c) 2009 Matthew Pocock <matthew.pocock@ncl.ac.uk>, (c) 2007-2009 Galois Inc., (c) 2010 Kevin Jardine, (c) 2012 Simon Hengel

From https://hackage.haskell.org/package/hexpat-0.20.13
     https://github.com/the-real-blackh/hexpat/blob/master/Text/XML/Expat/SAX.hs#L227

copied over because the upstream library doesn't expose this function.
-}
module Codec.Xlsx.Parser.Stream.HexpatInternal (parseBuf) where

import Control.Monad
import Text.XML.Expat.SAX
import qualified Data.ByteString.Internal as I
import Data.Bits
import Data.Int
import Data.ByteString.Internal (c_strlen)
import Data.Word
import Foreign.C
import Foreign.ForeignPtr
import Foreign.Ptr
import Foreign.Storable

{-# SCC parseBuf #-}
parseBuf :: (GenericXMLString tag, GenericXMLString text) =>
            ForeignPtr Word8 -> CInt -> (Ptr Word8 -> Int -> IO (a, Int)) -> IO [(SAXEvent tag text, a)]
parseBuf buf _ processExtra = withForeignPtr buf $ \pBuf -> doit [] pBuf 0
  where
    roundUp32 offset = (offset + 3) .&. complement 3
    doit acc pBuf offset0 = offset0 `seq` do
        typ <- peek (pBuf `plusPtr` offset0 :: Ptr Word32)
        (a, offset) <- processExtra pBuf (offset0 + 4)
        case typ of
            0 -> return (reverse acc)
            1 -> do
                nAtts <- peek (pBuf `plusPtr` offset :: Ptr Word32)
                let pName = pBuf `plusPtr` (offset + 4)
                lName <- fromIntegral <$> c_strlen pName
                let name = gxFromByteString $ I.fromForeignPtr buf (offset + 4) lName
                (atts, offset') <- foldM (\(atts, offset) _ -> do
                        let pAtt = pBuf `plusPtr` offset
                        lAtt <- fromIntegral <$> c_strlen pAtt
                        let att = gxFromByteString $ I.fromForeignPtr buf offset lAtt
                            offset' = offset + lAtt + 1
                            pValue = pBuf `plusPtr` offset'
                        lValue <- fromIntegral <$> c_strlen pValue
                        let value = gxFromByteString $ I.fromForeignPtr buf offset' lValue
                        return ((att, value):atts, offset' + lValue + 1)
                    ) ([], offset + 4 + lName + 1) [1,3..nAtts]
                doit ((StartElement name (reverse atts), a) : acc) pBuf (roundUp32 offset')
            2 -> do
                let pName = pBuf `plusPtr` offset
                lName <- fromIntegral <$> c_strlen pName
                let name = gxFromByteString $ I.fromForeignPtr buf offset lName
                    offset' = offset + lName + 1
                doit ((EndElement name, a) : acc) pBuf (roundUp32 offset')
            3 -> do
                len <- fromIntegral <$> peek (pBuf `plusPtr` offset :: Ptr Word32)
                let text = gxFromByteString $ I.fromForeignPtr buf (offset + 4) len
                    offset' = offset + 4 + len
                doit ((CharacterData text, a) : acc) pBuf (roundUp32 offset')
            4 -> do
                let pEnc = pBuf `plusPtr` offset
                lEnc <- fromIntegral <$> c_strlen pEnc
                let enc = gxFromByteString $ I.fromForeignPtr buf offset lEnc
                    offset' = offset + lEnc + 1
                    pVer = pBuf `plusPtr` offset'
                pVerFirst <- peek (castPtr pVer :: Ptr Word8)
                (mVer, offset'') <- case pVerFirst of
                    0 -> return (Nothing, offset' + 1)
                    1 -> do
                        lVer <- fromIntegral <$> c_strlen (pVer `plusPtr` 1)
                        return (Just $ gxFromByteString $ I.fromForeignPtr buf (offset' + 1) lVer, offset' + 1 + lVer + 1)
                    _ -> error "hexpat: bad data from C land"
                cSta <- peek (pBuf `plusPtr` offset'' :: Ptr Int8)
                let sta = if cSta < 0  then Nothing else
                          if cSta == 0 then Just False else
                                            Just True
                doit ((XMLDeclaration enc mVer sta, a) : acc) pBuf (roundUp32 (offset'' + 1))
            5 -> doit ((StartCData, a) : acc) pBuf offset
            6 -> doit ((EndCData, a) : acc) pBuf offset
            7 -> do
                let pTarget = pBuf `plusPtr` offset
                lTarget <- fromIntegral <$> c_strlen pTarget
                let target = gxFromByteString $ I.fromForeignPtr buf offset lTarget
                    offset' = offset + lTarget + 1
                    pData = pBuf `plusPtr` offset'
                lData <- fromIntegral <$> c_strlen pData
                let dat = gxFromByteString $ I.fromForeignPtr buf offset' lData
                doit ((ProcessingInstruction target dat, a) : acc) pBuf (roundUp32 (offset' + lData + 1))
            8 -> do
                let pText = pBuf `plusPtr` offset
                lText <- fromIntegral <$> c_strlen pText
                let text = gxFromByteString $ I.fromForeignPtr buf offset lText
                doit ((Comment text, a) : acc) pBuf (roundUp32 (offset + lText + 1))
            _ -> error "hexpat: bad data from C land"