content: {-# 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           Data.STRef.Unboxed
  import qualified Data.Vector.Unboxed         as UV
  import qualified Data.Vector.Unboxed.Mutable as UMV
  #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   <- newSTRefU 0
              parentRef <- newSTRefU 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 <- readSTRefU 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 <- readSTRefU parentRef
                   do writeSTRefU parentRef index
                      writeSTRefU 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 <- readSTRefU 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 writeSTRefU 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 <- readSTRefU 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 writeSTRefU 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 <- readSTRefU sizeRef
                   untilM $ do
                     parent <- readSTRefU 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)
                     writeSTRefU 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 <- readSTRefU 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 writeSTRefU 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 <- readSTRefU 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
  