{-
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
        Word32
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
a, Int
offset) <- Ptr Word8 -> Int -> IO (a, Int)
processExtra Ptr Word8
pBuf (Int
offset0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4)
        case Word32
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
                Word32
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 b
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)
                Int
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 :: tag
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
                ([(tag, text)]
atts, Int
offset') <- (([(tag, text)], Int) -> Word32 -> IO ([(tag, text)], Int))
-> ([(tag, text)], Int) -> [Word32] -> IO ([(tag, text)], Int)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
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
                        Int
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 :: tag
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
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 b
pValue = Ptr Word8
pBuf Ptr Word8 -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
offset'
                        Int
lValue <- 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
pValue
                        let value :: text
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
                        ([(tag, text)], Int) -> IO ([(tag, text)], Int)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((tag
att, text
value)(tag, text) -> [(tag, text)] -> [(tag, text)]
forall a. a -> [a] -> [a]
:[(tag, text)]
atts, Int
offset' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
lValue Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
                    ) ([], 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
lName Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [Word32
1,Word32
3..Word32
nAtts]
                [(SAXEvent tag text, a)]
-> Ptr Word8 -> Int -> IO [(SAXEvent tag text, a)]
doit ((tag -> [(tag, text)] -> SAXEvent tag text
forall tag text. tag -> [(tag, text)] -> SAXEvent tag text
StartElement tag
name ([(tag, text)] -> [(tag, text)]
forall a. [a] -> [a]
reverse [(tag, text)]
atts), 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 -> Int
forall {a}. (Bits a, Num a) => a -> a
roundUp32 Int
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
                Int
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 :: tag
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
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
                [(SAXEvent tag text, a)]
-> Ptr Word8 -> Int -> IO [(SAXEvent tag text, a)]
doit ((tag -> SAXEvent tag text
forall tag text. tag -> SAXEvent tag text
EndElement tag
name, 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 -> Int
forall {a}. (Bits a, Num a) => a -> a
roundUp32 Int
offset')
            Word32
3 -> do
                Int
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 :: text
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
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
                [(SAXEvent tag text, a)]
-> Ptr Word8 -> Int -> IO [(SAXEvent tag text, a)]
doit ((text -> SAXEvent tag text
forall tag text. text -> SAXEvent tag text
CharacterData text
text, 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 -> Int
forall {a}. (Bits a, Num a) => a -> a
roundUp32 Int
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
                Int
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 :: text
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
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 b
pVer = Ptr Word8
pBuf Ptr Word8 -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
offset'
                Word8
pVerFirst <- Ptr Word8 -> IO Word8
forall a. Storable a => Ptr a -> IO a
peek (Ptr Any -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr Ptr Any
forall {b}. Ptr b
pVer :: Ptr Word8)
                (Maybe text
mVer, Int
offset'') <- case Word8
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
                        Int
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 Any
forall {b}. Ptr b
pVer Ptr Any -> Int -> CString
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
1)
                        (Maybe text, Int) -> IO (Maybe text, Int)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (text -> Maybe text
forall a. a -> Maybe a
Just (text -> Maybe text) -> text -> Maybe text
forall a b. (a -> b) -> a -> b
$ 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
1) Int
lVer, Int
offset' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
lVer Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
                    Word8
_ -> [Char] -> IO (Maybe text, Int)
forall a. HasCallStack => [Char] -> a
error [Char]
"hexpat: bad data from C land"
                Int8
cSta <- Ptr Int8 -> IO Int8
forall a. Storable a => Ptr a -> IO a
peek (Ptr Word8
pBuf Ptr Word8 -> Int -> Ptr Int8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
offset'' :: Ptr Int8)
                let sta :: Maybe Bool
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
                [(SAXEvent tag text, a)]
-> Ptr Word8 -> Int -> IO [(SAXEvent tag text, a)]
doit ((text -> Maybe text -> Maybe Bool -> SAXEvent tag text
forall tag text.
text -> Maybe text -> Maybe Bool -> SAXEvent tag text
XMLDeclaration text
enc Maybe text
mVer Maybe Bool
sta, 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 -> Int
forall {a}. (Bits a, Num a) => a -> a
roundUp32 (Int
offset'' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
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
                Int
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 :: text
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
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 b
pData = Ptr Word8
pBuf Ptr Word8 -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
offset'
                Int
lData <- 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
pData
                let dat :: text
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
                [(SAXEvent tag text, a)]
-> Ptr Word8 -> Int -> IO [(SAXEvent tag text, a)]
doit ((text -> text -> SAXEvent tag text
forall tag text. text -> text -> SAXEvent tag text
ProcessingInstruction text
target text
dat, 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 -> Int
forall {a}. (Bits a, Num a) => a -> a
roundUp32 (Int
offset' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
lData Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
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
                Int
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 :: text
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
                [(SAXEvent tag text, a)]
-> Ptr Word8 -> Int -> IO [(SAXEvent tag text, a)]
doit ((text -> SAXEvent tag text
forall tag text. text -> SAXEvent tag text
Comment text
text, 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 -> Int
forall {a}. (Bits a, Num a) => a -> a
roundUp32 (Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
lText Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))
            Word32
_ -> [Char] -> IO [(SAXEvent tag text, a)]
forall a. HasCallStack => [Char] -> a
error [Char]
"hexpat: bad data from C land"