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