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