xeno-0.5: src/Xeno/DOM/Robust.hs
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE CPP #-}
-- | DOM parser and API for XML.
-- Slightly slower DOM parsing,
-- but add missing close tags.
module Xeno.DOM.Robust
( parse
, Node
, Content(..)
, name
, attributes
, contents
, children
) where
import Control.Monad.ST
import Control.Spork
#if MIN_VERSION_bytestring(0,11,0)
import Data.ByteString.Internal as BS (ByteString(..), plusForeignPtr)
#else
import Data.ByteString.Internal(ByteString(..))
#endif
import Data.STRef
import qualified Data.Vector.Unboxed as UV
import qualified Data.Vector.Unboxed.Mutable as UMV
import Data.Mutable(asURef, newRef, readRef, writeRef)
#if MIN_VERSION_bytestring(0,11,0)
import Foreign.Ptr (minusPtr)
import Foreign.ForeignPtr (ForeignPtr, withForeignPtr)
import System.IO.Unsafe (unsafeDupablePerformIO)
#endif
import Xeno.SAX
import Xeno.Types
import Xeno.DOM.Internal(Node(..), Content(..), name, attributes, contents, children)
-- | Parse a complete Nodes document.
parse :: ByteString -> Either XenoException Node
parse inp =
case spork node of
Left e -> Left e
Right r ->
case findRootNode r of
Just n -> Right n
Nothing -> Left XenoExpectRootNode
where
findRootNode r = go 0
where
go n = case r UV.!? n of
Just 0x0 -> Just (Node str n r)
-- skipping text assuming that it contains only white space
-- characters
Just 0x1 -> go (n+3)
_ -> Nothing
#if MIN_VERSION_bytestring(0,11,0)
BS offset0 _ = str
#else
PS _ offset0 _ = str
#endif
str = skipDoctype inp
node =
runST
(do nil <- UMV.new 1000
vecRef <- newSTRef nil
sizeRef <- fmap asURef $ newRef 0
parentRef <- fmap asURef $ newRef 0
process Process {
#if MIN_VERSION_bytestring(0,11,0)
openF = \(BS name_start name_len) -> do
#else
openF = \(PS _ name_start name_len) -> do
#endif
let tag = 0x00
tag_end = -1
index <- readRef sizeRef
v' <-
do v <- readSTRef vecRef
if index + 5 < UMV.length v
then pure v
else do
v' <- UMV.grow v (UMV.length v)
writeSTRef vecRef v'
return v'
tag_parent <- readRef parentRef
do writeRef parentRef index
writeRef sizeRef (index + 5)
UMV.write v' index tag
UMV.write v' (index + 1) tag_parent
UMV.write v' (index + 2) (distance name_start offset0)
UMV.write v' (index + 3) name_len
UMV.write v' (index + 4) tag_end
#if MIN_VERSION_bytestring(0,11,0)
, attrF = \(BS key_start key_len) (BS value_start value_len) -> do
#else
, attrF = \(PS _ key_start key_len) (PS _ value_start value_len) -> do
#endif
index <- readRef sizeRef
v' <-
do v <- readSTRef vecRef
if index + 5 < UMV.length v
then pure v
else do
v' <- UMV.grow v (UMV.length v)
writeSTRef vecRef v'
return v'
let tag = 0x02
do writeRef sizeRef (index + 5)
do UMV.write v' index tag
UMV.write v' (index + 1) (distance key_start offset0)
UMV.write v' (index + 2) key_len
UMV.write v' (index + 3) (distance value_start offset0)
UMV.write v' (index + 4) value_len
, endOpenF = \_ -> return ()
#if MIN_VERSION_bytestring(0,11,0)
, textF = \(BS text_start text_len) -> do
#else
, textF = \(PS _ text_start text_len) -> do
#endif
let tag = 0x01
index <- readRef sizeRef
v' <-
do v <- readSTRef vecRef
if index + 3 < UMV.length v
then pure v
else do
v' <- UMV.grow v (UMV.length v)
writeSTRef vecRef v'
return v'
do writeRef sizeRef (index + 3)
do UMV.write v' index tag
UMV.write v' (index + 1) (distance text_start offset0)
UMV.write v' (index + 2) text_len
#if MIN_VERSION_bytestring(0,11,0)
, closeF = \closeTag@(BS _ _) -> do
#else
, closeF = \closeTag@(PS s _ _) -> do
#endif
v <- readSTRef vecRef
-- Set the tag_end slot of the parent.
index <- readRef sizeRef
untilM $ do
parent <- readRef parentRef
correctTag <- if parent == 0
then return True -- no more tags to close!!!
else do
parent_name <- UMV.read v (parent + 2)
parent_len <- UMV.read v (parent + 3)
#if MIN_VERSION_bytestring(0,11,0)
let openTag = BS (BS.plusForeignPtr offset0 parent_name) parent_len
#else
let openTag = PS s (parent_name+offset0) parent_len
#endif
return $ openTag == closeTag
UMV.write v (parent + 4) index
-- Pop the stack and return to the parent element.
previousParent <- UMV.read v (parent + 1)
writeRef parentRef previousParent
return correctTag -- continue closing tags, until matching one is found
#if MIN_VERSION_bytestring(0,11,0)
, cdataF = \(BS cdata_start cdata_len) -> do
#else
, cdataF = \(PS _ cdata_start cdata_len) -> do
#endif
let tag = 0x03
index <- readRef sizeRef
v' <-
do v <- readSTRef vecRef
if index + 3 < UMV.length v
then pure v
else do
v' <- UMV.grow v (UMV.length v)
writeSTRef vecRef v'
return v'
do writeRef sizeRef (index + 3)
do UMV.write v' index tag
UMV.write v' (index + 1) (distance cdata_start offset0)
UMV.write v' (index + 2) cdata_len
} str
wet <- readSTRef vecRef
arr <- UV.unsafeFreeze wet
size <- readRef sizeRef
return (UV.unsafeSlice 0 size arr))
untilM :: Monad m => m Bool -> m ()
untilM loop = do
cond <- loop
case cond of
True -> return ()
False -> untilM loop
#if MIN_VERSION_bytestring(0,11,0)
minusForeignPtr :: ForeignPtr a -> ForeignPtr b -> Int
minusForeignPtr fpA fpB = unsafeDupablePerformIO $
withForeignPtr fpA $ \ptrA -> withForeignPtr fpB $ \ptrB ->
pure (minusPtr ptrA ptrB)
distance :: ForeignPtr a -> ForeignPtr b -> Int
distance = minusForeignPtr
#else
distance :: Int -> Int -> Int
distance a b = a - b
#endif