{-# LANGUAGE RecordWildCards, BangPatterns #-}

-- | A module for fast first-approximation parsing of XML.
--   Note that entities, e.g. @&@, are not expanded.
module Text.XML.Hexml(
    Node, Attribute(..),
    parse, render,
    location, name, inner, outer,
    attributes, children, contents,
    attributeBy, childrenBy
    ) where

import Control.Applicative
import Control.Monad
import Data.Int
import Foreign.C
import Foreign.Ptr
import Foreign.Marshal hiding (void)
import Foreign.ForeignPtr
import Foreign.Storable
import System.IO.Unsafe
import Data.Monoid
import Data.Tuple.Extra
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Unsafe as BS
import qualified Data.ByteString.Internal as BS
import Prelude

data CDocument
data CNode
data CAttr

szAttr :: Int
szAttr = Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Str -> Int
forall a. Storable a => a -> Int
sizeOf (Str
forall a. HasCallStack => a
undefined :: Str)
szNode :: Int
szNode = Int
5 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Str -> Int
forall a. Storable a => a -> Int
sizeOf (Str
forall a. HasCallStack => a
undefined :: Str)


data Str = Str {Str -> Int32
strStart :: {-# UNPACK #-} !Int32, Str -> Int32
strLength :: {-# UNPACK #-} !Int32} deriving Int -> Str -> ShowS
[Str] -> ShowS
Str -> String
(Int -> Str -> ShowS)
-> (Str -> String) -> ([Str] -> ShowS) -> Show Str
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Str -> ShowS
showsPrec :: Int -> Str -> ShowS
$cshow :: Str -> String
show :: Str -> String
$cshowList :: [Str] -> ShowS
showList :: [Str] -> ShowS
Show

strEnd :: Str -> Int32
strEnd :: Str -> Int32
strEnd Str{Int32
strStart :: Str -> Int32
strLength :: Str -> Int32
strStart :: Int32
strLength :: Int32
..} = Int32
strStart Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+ Int32
strLength

instance Storable Str where
    sizeOf :: Str -> Int
sizeOf Str
_ = Int
8
    alignment :: Str -> Int
alignment Str
_ = Int64 -> Int
forall a. Storable a => a -> Int
alignment (Int64
0 :: Int64)
    peek :: Ptr Str -> IO Str
peek Ptr Str
p = Int32 -> Int32 -> Str
Str (Int32 -> Int32 -> Str) -> IO Int32 -> IO (Int32 -> Str)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr Str -> Int -> IO Int32
forall b. Ptr b -> Int -> IO Int32
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr Str
p Int
0 IO (Int32 -> Str) -> IO Int32 -> IO Str
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Ptr Str -> Int -> IO Int32
forall b. Ptr b -> Int -> IO Int32
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr Str
p Int
4
    poke :: Ptr Str -> Str -> IO ()
poke Ptr Str
p Str{Int32
strStart :: Str -> Int32
strLength :: Str -> Int32
strStart :: Int32
strLength :: Int32
..} = Ptr Str -> Int -> Int32 -> IO ()
forall b. Ptr b -> Int -> Int32 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr Str
p Int
0 Int32
strStart IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Ptr Str -> Int -> Int32 -> IO ()
forall b. Ptr b -> Int -> Int32 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr Str
p Int
4 Int32
strLength

foreign import ccall hexml_document_parse :: CString -> CInt -> IO (Ptr CDocument)
foreign import ccall hexml_document_free :: Ptr CDocument -> IO ()
foreign import ccall "&hexml_document_free" hexml_document_free_funptr :: FunPtr (Ptr CDocument -> IO ())
foreign import ccall hexml_node_render :: Ptr CDocument -> Ptr CNode -> CString -> CInt -> IO CInt
foreign import ccall unsafe hexml_document_error :: Ptr CDocument -> IO CString
foreign import ccall unsafe hexml_document_node :: Ptr CDocument -> IO (Ptr CNode)

foreign import ccall unsafe hexml_node_children :: Ptr CDocument -> Ptr CNode -> Ptr CInt -> IO (Ptr CNode)
foreign import ccall unsafe hexml_node_attributes :: Ptr CDocument -> Ptr CNode -> Ptr CInt -> IO (Ptr CAttr)

foreign import ccall unsafe hexml_node_child :: Ptr CDocument -> Ptr CNode -> Ptr CNode -> CString -> CInt -> IO (Ptr CNode)
foreign import ccall unsafe hexml_node_attribute :: Ptr CDocument -> Ptr CNode -> CString -> CInt -> IO (Ptr CAttr)

-- | A node in an XML document, created by 'parse', then calling functions such
--   as 'children' on that initial 'Node'.
data Node = Node BS.ByteString (ForeignPtr CDocument) (Ptr CNode)

-- | An XML attribute, comprising of a name and a value. As an example,
--   @hello=\"world\"@ would produce @Attribute \"hello\" \"world\"@.
data Attribute = Attribute
    {Attribute -> ByteString
attributeName :: BS.ByteString
    ,Attribute -> ByteString
attributeValue :: BS.ByteString
    } deriving (Int -> Attribute -> ShowS
[Attribute] -> ShowS
Attribute -> String
(Int -> Attribute -> ShowS)
-> (Attribute -> String)
-> ([Attribute] -> ShowS)
-> Show Attribute
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Attribute -> ShowS
showsPrec :: Int -> Attribute -> ShowS
$cshow :: Attribute -> String
show :: Attribute -> String
$cshowList :: [Attribute] -> ShowS
showList :: [Attribute] -> ShowS
Show, Attribute -> Attribute -> Bool
(Attribute -> Attribute -> Bool)
-> (Attribute -> Attribute -> Bool) -> Eq Attribute
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Attribute -> Attribute -> Bool
== :: Attribute -> Attribute -> Bool
$c/= :: Attribute -> Attribute -> Bool
/= :: Attribute -> Attribute -> Bool
Eq, Eq Attribute
Eq Attribute =>
(Attribute -> Attribute -> Ordering)
-> (Attribute -> Attribute -> Bool)
-> (Attribute -> Attribute -> Bool)
-> (Attribute -> Attribute -> Bool)
-> (Attribute -> Attribute -> Bool)
-> (Attribute -> Attribute -> Attribute)
-> (Attribute -> Attribute -> Attribute)
-> Ord Attribute
Attribute -> Attribute -> Bool
Attribute -> Attribute -> Ordering
Attribute -> Attribute -> Attribute
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Attribute -> Attribute -> Ordering
compare :: Attribute -> Attribute -> Ordering
$c< :: Attribute -> Attribute -> Bool
< :: Attribute -> Attribute -> Bool
$c<= :: Attribute -> Attribute -> Bool
<= :: Attribute -> Attribute -> Bool
$c> :: Attribute -> Attribute -> Bool
> :: Attribute -> Attribute -> Bool
$c>= :: Attribute -> Attribute -> Bool
>= :: Attribute -> Attribute -> Bool
$cmax :: Attribute -> Attribute -> Attribute
max :: Attribute -> Attribute -> Attribute
$cmin :: Attribute -> Attribute -> Attribute
min :: Attribute -> Attribute -> Attribute
Ord)

instance Show Node where
    show :: Node -> String
show Node
d = String
"Node " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show (ByteString -> String
BS.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ Node -> ByteString
outer Node
d)


touchBS :: BS.ByteString -> IO ()
touchBS :: ByteString -> IO ()
touchBS = ForeignPtr Word8 -> IO ()
forall a. ForeignPtr a -> IO ()
touchForeignPtr (ForeignPtr Word8 -> IO ())
-> (ByteString -> ForeignPtr Word8) -> ByteString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ForeignPtr Word8, Int, Int) -> ForeignPtr Word8
forall a b c. (a, b, c) -> a
fst3 ((ForeignPtr Word8, Int, Int) -> ForeignPtr Word8)
-> (ByteString -> (ForeignPtr Word8, Int, Int))
-> ByteString
-> ForeignPtr Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> (ForeignPtr Word8, Int, Int)
BS.toForeignPtr


-- | Parse a ByteString as an XML document, returning a 'Left' error message, or a 'Right' document.
--   Note that the returned node will have a 'name' of @\"\"@, no 'attributes', and 'contents' as per the document.
--   Often the first child will be the @\<?xml ... ?\>@ element. For documents which comprise an XML node and a single
--   root element, use @'children' n !! 1@.
parse :: BS.ByteString -> Either BS.ByteString Node
parse :: ByteString -> Either ByteString Node
parse ByteString
src = do
    let src0 :: ByteString
src0 = ByteString
src ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Char -> ByteString
BS.singleton Char
'\0'
    IO (Either ByteString Node) -> Either ByteString Node
forall a. IO a -> a
unsafePerformIO (IO (Either ByteString Node) -> Either ByteString Node)
-> IO (Either ByteString Node) -> Either ByteString Node
forall a b. (a -> b) -> a -> b
$ ByteString
-> (CStringLen -> IO (Either ByteString Node))
-> IO (Either ByteString Node)
forall a. ByteString -> (CStringLen -> IO a) -> IO a
BS.unsafeUseAsCStringLen ByteString
src0 ((CStringLen -> IO (Either ByteString Node))
 -> IO (Either ByteString Node))
-> (CStringLen -> IO (Either ByteString Node))
-> IO (Either ByteString Node)
forall a b. (a -> b) -> a -> b
$ \(CString
str, Int
len) -> do
        Ptr CDocument
doc <- CString -> CInt -> IO (Ptr CDocument)
hexml_document_parse CString
str (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len CInt -> CInt -> CInt
forall a. Num a => a -> a -> a
- CInt
1)
        CString
err <- Ptr CDocument -> IO CString
hexml_document_error Ptr CDocument
doc
        if CString
err CString -> CString -> Bool
forall a. Eq a => a -> a -> Bool
/= CString
forall a. Ptr a
nullPtr then do
            ByteString
bs <- CString -> IO ByteString
BS.packCString (CString -> IO ByteString) -> IO CString -> IO ByteString
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr CDocument -> IO CString
hexml_document_error Ptr CDocument
doc
            Ptr CDocument -> IO ()
hexml_document_free Ptr CDocument
doc
            Either ByteString Node -> IO (Either ByteString Node)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ByteString Node -> IO (Either ByteString Node))
-> Either ByteString Node -> IO (Either ByteString Node)
forall a b. (a -> b) -> a -> b
$ ByteString -> Either ByteString Node
forall a b. a -> Either a b
Left ByteString
bs
         else do
            Ptr CNode
node <- Ptr CDocument -> IO (Ptr CNode)
hexml_document_node Ptr CDocument
doc
            ForeignPtr CDocument
doc <- FinalizerPtr CDocument
-> Ptr CDocument -> IO (ForeignPtr CDocument)
forall a. FinalizerPtr a -> Ptr a -> IO (ForeignPtr a)
newForeignPtr FinalizerPtr CDocument
hexml_document_free_funptr Ptr CDocument
doc
            Either ByteString Node -> IO (Either ByteString Node)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ByteString Node -> IO (Either ByteString Node))
-> Either ByteString Node -> IO (Either ByteString Node)
forall a b. (a -> b) -> a -> b
$ Node -> Either ByteString Node
forall a b. b -> Either a b
Right (Node -> Either ByteString Node) -> Node -> Either ByteString Node
forall a b. (a -> b) -> a -> b
$ ByteString -> ForeignPtr CDocument -> Ptr CNode -> Node
Node ByteString
src0 ForeignPtr CDocument
doc Ptr CNode
node

-- | Given a node, rerender it to something with an equivalent parse tree.
--   Mostly useful for debugging - if you want the real source document use 'outer' instead.
render :: Node -> BS.ByteString
render :: Node -> ByteString
render (Node ByteString
src ForeignPtr CDocument
doc Ptr CNode
n) = IO ByteString -> ByteString
forall a. IO a -> a
unsafePerformIO (IO ByteString -> ByteString) -> IO ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ForeignPtr CDocument
-> (Ptr CDocument -> IO ByteString) -> IO ByteString
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr CDocument
doc ((Ptr CDocument -> IO ByteString) -> IO ByteString)
-> (Ptr CDocument -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr CDocument
d -> do
    CInt
i <- Ptr CDocument -> Ptr CNode -> CString -> CInt -> IO CInt
hexml_node_render Ptr CDocument
d Ptr CNode
n CString
forall a. Ptr a
nullPtr CInt
0
    ByteString
res <- Int -> (Ptr Word8 -> IO ()) -> IO ByteString
BS.create (CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
i) ((Ptr Word8 -> IO ()) -> IO ByteString)
-> (Ptr Word8 -> IO ()) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
ptr -> IO CInt -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO CInt -> IO ()) -> IO CInt -> IO ()
forall a b. (a -> b) -> a -> b
$ Ptr CDocument -> Ptr CNode -> CString -> CInt -> IO CInt
hexml_node_render Ptr CDocument
d Ptr CNode
n (Ptr Word8 -> CString
forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
ptr) CInt
i
    ByteString -> IO ()
touchBS ByteString
src
    ByteString -> IO ByteString
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
res

applyStr :: BS.ByteString -> Str -> BS.ByteString
applyStr :: ByteString -> Str -> ByteString
applyStr ByteString
bs Str{Int32
strStart :: Str -> Int32
strLength :: Str -> Int32
strStart :: Int32
strLength :: Int32
..} = Int -> ByteString -> ByteString
BS.take (Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
strLength) (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.drop (Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
strStart) ByteString
bs

nodeStr :: Int -> Node -> Str
nodeStr :: Int -> Node -> Str
nodeStr Int
i (Node ByteString
src ForeignPtr CDocument
doc Ptr CNode
n) = IO Str -> Str
forall a. IO a -> a
unsafePerformIO (IO Str -> Str) -> IO Str -> Str
forall a b. (a -> b) -> a -> b
$ ForeignPtr CDocument -> (Ptr CDocument -> IO Str) -> IO Str
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr CDocument
doc ((Ptr CDocument -> IO Str) -> IO Str)
-> (Ptr CDocument -> IO Str) -> IO Str
forall a b. (a -> b) -> a -> b
$ \Ptr CDocument
_ -> Ptr Str -> Int -> IO Str
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff (Ptr CNode -> Ptr Str
forall a b. Ptr a -> Ptr b
castPtr Ptr CNode
n) Int
i

nodeBS :: Int -> Node -> BS.ByteString
nodeBS :: Int -> Node -> ByteString
nodeBS Int
i node :: Node
node@(Node ByteString
src ForeignPtr CDocument
doc Ptr CNode
n) = ByteString -> Str -> ByteString
applyStr ByteString
src (Str -> ByteString) -> Str -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> Node -> Str
nodeStr Int
i Node
node

attrPeek :: BS.ByteString -> ForeignPtr CDocument -> Ptr CAttr -> Attribute
attrPeek :: ByteString -> ForeignPtr CDocument -> Ptr CAttr -> Attribute
attrPeek ByteString
src ForeignPtr CDocument
doc Ptr CAttr
a = IO Attribute -> Attribute
forall a. IO a -> a
unsafePerformIO (IO Attribute -> Attribute) -> IO Attribute -> Attribute
forall a b. (a -> b) -> a -> b
$ ForeignPtr CDocument
-> (Ptr CDocument -> IO Attribute) -> IO Attribute
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr CDocument
doc ((Ptr CDocument -> IO Attribute) -> IO Attribute)
-> (Ptr CDocument -> IO Attribute) -> IO Attribute
forall a b. (a -> b) -> a -> b
$ \Ptr CDocument
_ -> do
    ByteString
name <- ByteString -> Str -> ByteString
applyStr ByteString
src (Str -> ByteString) -> IO Str -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr Str -> Int -> IO Str
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff (Ptr CAttr -> Ptr Str
forall a b. Ptr a -> Ptr b
castPtr Ptr CAttr
a) Int
0
    ByteString
val  <- ByteString -> Str -> ByteString
applyStr ByteString
src (Str -> ByteString) -> IO Str -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr Str -> Int -> IO Str
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff (Ptr CAttr -> Ptr Str
forall a b. Ptr a -> Ptr b
castPtr Ptr CAttr
a) Int
1
    Attribute -> IO Attribute
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Attribute -> IO Attribute) -> Attribute -> IO Attribute
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> Attribute
Attribute ByteString
name ByteString
val

-- | Get the name of a node, e.g. @\<test /\>@ produces @\"test\"@.
name :: Node -> BS.ByteString
name :: Node -> ByteString
name = Int -> Node -> ByteString
nodeBS Int
0

-- | Get the inner text, from inside the tag, e.g. @\<test /\>@ produces @\"\"@
--   and @\<test\>hello\</test\>@ produces @\"hello\"@.
--   The result will have identical layout/spacing to the source document.
inner :: Node -> BS.ByteString
inner :: Node -> ByteString
inner = Int -> Node -> ByteString
nodeBS Int
1

-- | Get the outer text, including the tag itself, e.g. @\<test /\>@ produces @\"\<test /\>\"@
--   and @\<test\>hello\</test\>@ produces @\"\<test\>hello\</test\>\"@.
--   The result will have identical layout/spacing to the source document.
outer :: Node -> BS.ByteString
outer :: Node -> ByteString
outer = Int -> Node -> ByteString
nodeBS Int
2

-- | Get the contents of a node, including both the content strings (as 'Left', never blank) and
--   the direct child nodes (as 'Right').
--   If you only want the child nodes, use 'children'.
contents :: Node -> [Either BS.ByteString Node]
contents :: Node -> [Either ByteString Node]
contents n :: Node
n@(Node ByteString
src ForeignPtr CDocument
_ Ptr CNode
_) = Int32 -> [(Str, Node)] -> [Either ByteString Node]
forall {b}. Int32 -> [(Str, b)] -> [Either ByteString b]
f (Str -> Int32
strStart Str
inner) [(Str, Node)]
outers
    where
        f :: Int32 -> [(Str, b)] -> [Either ByteString b]
f Int32
i [] = Int32 -> Int32 -> [Either ByteString b]
forall {b}. Int32 -> Int32 -> [Either ByteString b]
string Int32
i (Str -> Int32
strEnd Str
inner)
        f Int32
i ((Str
x, b
n):[(Str, b)]
xs) = Int32 -> Int32 -> [Either ByteString b]
forall {b}. Int32 -> Int32 -> [Either ByteString b]
string Int32
i (Str -> Int32
strStart Str
x) [Either ByteString b]
-> [Either ByteString b] -> [Either ByteString b]
forall a. [a] -> [a] -> [a]
++ b -> Either ByteString b
forall a b. b -> Either a b
Right b
n Either ByteString b
-> [Either ByteString b] -> [Either ByteString b]
forall a. a -> [a] -> [a]
: Int32 -> [(Str, b)] -> [Either ByteString b]
f (Str -> Int32
strEnd Str
x) [(Str, b)]
xs

        string :: Int32 -> Int32 -> [Either ByteString b]
string Int32
start Int32
end | Int32
start Int32 -> Int32 -> Bool
forall a. Eq a => a -> a -> Bool
== Int32
end = []
                         | Bool
otherwise = [ByteString -> Either ByteString b
forall a b. a -> Either a b
Left (ByteString -> Either ByteString b)
-> ByteString -> Either ByteString b
forall a b. (a -> b) -> a -> b
$ ByteString -> Str -> ByteString
applyStr ByteString
src (Str -> ByteString) -> Str -> ByteString
forall a b. (a -> b) -> a -> b
$ Int32 -> Int32 -> Str
Str Int32
start (Int32
end Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
- Int32
start)]
        inner :: Str
inner = Int -> Node -> Str
nodeStr Int
1 Node
n
        outers :: [(Str, Node)]
outers = (Node -> (Str, Node)) -> [Node] -> [(Str, Node)]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Node -> Str
nodeStr Int
2 (Node -> Str) -> (Node -> Node) -> Node -> (Str, Node)
forall a b c. (a -> b) -> (a -> c) -> a -> (b, c)
&&& Node -> Node
forall a. a -> a
id) ([Node] -> [(Str, Node)]) -> [Node] -> [(Str, Node)]
forall a b. (a -> b) -> a -> b
$ Node -> [Node]
children Node
n

-- | Get the direct child nodes of this node.
children :: Node -> [Node]
children :: Node -> [Node]
children (Node ByteString
src ForeignPtr CDocument
doc Ptr CNode
n) = IO [Node] -> [Node]
forall a. IO a -> a
unsafePerformIO (IO [Node] -> [Node]) -> IO [Node] -> [Node]
forall a b. (a -> b) -> a -> b
$ ForeignPtr CDocument -> (Ptr CDocument -> IO [Node]) -> IO [Node]
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr CDocument
doc ((Ptr CDocument -> IO [Node]) -> IO [Node])
-> (Ptr CDocument -> IO [Node]) -> IO [Node]
forall a b. (a -> b) -> a -> b
$ \Ptr CDocument
d ->
    (Ptr CInt -> IO [Node]) -> IO [Node]
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CInt -> IO [Node]) -> IO [Node])
-> (Ptr CInt -> IO [Node]) -> IO [Node]
forall a b. (a -> b) -> a -> b
$ \Ptr CInt
count -> do
        Ptr CNode
res <- Ptr CDocument -> Ptr CNode -> Ptr CInt -> IO (Ptr CNode)
hexml_node_children Ptr CDocument
d Ptr CNode
n Ptr CInt
count
        Int
count <- CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CInt -> Int) -> IO CInt -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr CInt -> IO CInt
forall a. Storable a => Ptr a -> IO a
peek Ptr CInt
count
        [Node] -> IO [Node]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ByteString -> ForeignPtr CDocument -> Ptr CNode -> Node
Node ByteString
src ForeignPtr CDocument
doc (Ptr CNode -> Node) -> Ptr CNode -> Node
forall a b. (a -> b) -> a -> b
$ Ptr CNode -> Int -> Ptr CNode
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr CNode
res (Int -> Ptr CNode) -> Int -> Ptr CNode
forall a b. (a -> b) -> a -> b
$ Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
*Int
szNode | Int
i <- [Int
0..Int
countInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]]

-- | Get the attributes of this node.
attributes :: Node -> [Attribute]
attributes :: Node -> [Attribute]
attributes (Node ByteString
src ForeignPtr CDocument
doc Ptr CNode
n) = IO [Attribute] -> [Attribute]
forall a. IO a -> a
unsafePerformIO (IO [Attribute] -> [Attribute]) -> IO [Attribute] -> [Attribute]
forall a b. (a -> b) -> a -> b
$ ForeignPtr CDocument
-> (Ptr CDocument -> IO [Attribute]) -> IO [Attribute]
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr CDocument
doc ((Ptr CDocument -> IO [Attribute]) -> IO [Attribute])
-> (Ptr CDocument -> IO [Attribute]) -> IO [Attribute]
forall a b. (a -> b) -> a -> b
$ \Ptr CDocument
d ->
    (Ptr CInt -> IO [Attribute]) -> IO [Attribute]
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CInt -> IO [Attribute]) -> IO [Attribute])
-> (Ptr CInt -> IO [Attribute]) -> IO [Attribute]
forall a b. (a -> b) -> a -> b
$ \Ptr CInt
count -> do
        Ptr CAttr
res <- Ptr CDocument -> Ptr CNode -> Ptr CInt -> IO (Ptr CAttr)
hexml_node_attributes Ptr CDocument
d Ptr CNode
n Ptr CInt
count
        Int
count <- CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CInt -> Int) -> IO CInt -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr CInt -> IO CInt
forall a. Storable a => Ptr a -> IO a
peek Ptr CInt
count
        [Attribute] -> IO [Attribute]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ByteString -> ForeignPtr CDocument -> Ptr CAttr -> Attribute
attrPeek ByteString
src ForeignPtr CDocument
doc (Ptr CAttr -> Attribute) -> Ptr CAttr -> Attribute
forall a b. (a -> b) -> a -> b
$ Ptr CAttr -> Int -> Ptr CAttr
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr CAttr
res (Int -> Ptr CAttr) -> Int -> Ptr CAttr
forall a b. (a -> b) -> a -> b
$ Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
*Int
szAttr | Int
i <- [Int
0..Int
countInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]]

-- | Get the direct children of this node which have a specific name.
--   A more efficient version of:
--
-- > childrenBy p s = filter (\n -> name n == s) $ children p
childrenBy :: Node -> BS.ByteString -> [Node]
childrenBy :: Node -> ByteString -> [Node]
childrenBy (Node ByteString
src ForeignPtr CDocument
doc Ptr CNode
n) ByteString
str = Ptr CNode -> [Node]
go Ptr CNode
forall a. Ptr a
nullPtr
    where
        go :: Ptr CNode -> [Node]
go Ptr CNode
old = IO [Node] -> [Node]
forall a. IO a -> a
unsafePerformIO (IO [Node] -> [Node]) -> IO [Node] -> [Node]
forall a b. (a -> b) -> a -> b
$ ForeignPtr CDocument -> (Ptr CDocument -> IO [Node]) -> IO [Node]
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr CDocument
doc ((Ptr CDocument -> IO [Node]) -> IO [Node])
-> (Ptr CDocument -> IO [Node]) -> IO [Node]
forall a b. (a -> b) -> a -> b
$ \Ptr CDocument
d ->
            ByteString -> (CStringLen -> IO [Node]) -> IO [Node]
forall a. ByteString -> (CStringLen -> IO a) -> IO a
BS.unsafeUseAsCStringLen ByteString
str ((CStringLen -> IO [Node]) -> IO [Node])
-> (CStringLen -> IO [Node]) -> IO [Node]
forall a b. (a -> b) -> a -> b
$ \(CString
bs, Int
len) -> do
                Ptr CNode
r <- Ptr CDocument
-> Ptr CNode -> Ptr CNode -> CString -> CInt -> IO (Ptr CNode)
hexml_node_child Ptr CDocument
d Ptr CNode
n Ptr CNode
old CString
bs (CInt -> IO (Ptr CNode)) -> CInt -> IO (Ptr CNode)
forall a b. (a -> b) -> a -> b
$ Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len
                ByteString -> IO ()
touchBS ByteString
src
                [Node] -> IO [Node]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Node] -> IO [Node]) -> [Node] -> IO [Node]
forall a b. (a -> b) -> a -> b
$ if Ptr CNode
r Ptr CNode -> Ptr CNode -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr CNode
forall a. Ptr a
nullPtr then [] else ByteString -> ForeignPtr CDocument -> Ptr CNode -> Node
Node ByteString
src ForeignPtr CDocument
doc Ptr CNode
r Node -> [Node] -> [Node]
forall a. a -> [a] -> [a]
: Ptr CNode -> [Node]
go Ptr CNode
r

-- | Get the first attribute of this node which has a specific name, if there is one.
--   A more efficient version of:
--
-- > attributeBy n s = listToMaybe $ filter (\(Attribute a _) -> a == s $ attributes n
attributeBy :: Node -> BS.ByteString -> Maybe Attribute
attributeBy :: Node -> ByteString -> Maybe Attribute
attributeBy (Node ByteString
src ForeignPtr CDocument
doc Ptr CNode
n) ByteString
str = IO (Maybe Attribute) -> Maybe Attribute
forall a. IO a -> a
unsafePerformIO (IO (Maybe Attribute) -> Maybe Attribute)
-> IO (Maybe Attribute) -> Maybe Attribute
forall a b. (a -> b) -> a -> b
$ ForeignPtr CDocument
-> (Ptr CDocument -> IO (Maybe Attribute)) -> IO (Maybe Attribute)
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr CDocument
doc ((Ptr CDocument -> IO (Maybe Attribute)) -> IO (Maybe Attribute))
-> (Ptr CDocument -> IO (Maybe Attribute)) -> IO (Maybe Attribute)
forall a b. (a -> b) -> a -> b
$ \Ptr CDocument
d ->
    ByteString
-> (CStringLen -> IO (Maybe Attribute)) -> IO (Maybe Attribute)
forall a. ByteString -> (CStringLen -> IO a) -> IO a
BS.unsafeUseAsCStringLen ByteString
str ((CStringLen -> IO (Maybe Attribute)) -> IO (Maybe Attribute))
-> (CStringLen -> IO (Maybe Attribute)) -> IO (Maybe Attribute)
forall a b. (a -> b) -> a -> b
$ \(CString
bs, Int
len) -> do
        Ptr CAttr
r <- Ptr CDocument -> Ptr CNode -> CString -> CInt -> IO (Ptr CAttr)
hexml_node_attribute Ptr CDocument
d Ptr CNode
n CString
bs (CInt -> IO (Ptr CAttr)) -> CInt -> IO (Ptr CAttr)
forall a b. (a -> b) -> a -> b
$ Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len
        ByteString -> IO ()
touchBS ByteString
src
        Maybe Attribute -> IO (Maybe Attribute)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Attribute -> IO (Maybe Attribute))
-> Maybe Attribute -> IO (Maybe Attribute)
forall a b. (a -> b) -> a -> b
$ if Ptr CAttr
r Ptr CAttr -> Ptr CAttr -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr CAttr
forall a. Ptr a
nullPtr then Maybe Attribute
forall a. Maybe a
Nothing else Attribute -> Maybe Attribute
forall a. a -> Maybe a
Just (Attribute -> Maybe Attribute) -> Attribute -> Maybe Attribute
forall a b. (a -> b) -> a -> b
$ ByteString -> ForeignPtr CDocument -> Ptr CAttr -> Attribute
attrPeek ByteString
src ForeignPtr CDocument
doc Ptr CAttr
r

-- | Find the starting location of a node, the @<@ character.
--   The first character will be reported as @(line 1,column 1)@, because thats
--   how error messages typically do it.
location :: Node -> (Int, Int)
location :: Node -> (Int, Int)
location n :: Node
n@(Node ByteString
src ForeignPtr CDocument
_ Ptr CNode
_) = ((Int, Int) -> Char -> (Int, Int))
-> (Int, Int) -> ByteString -> (Int, Int)
forall a. (a -> Char -> a) -> a -> ByteString -> a
BS.foldl' (Int, Int) -> Char -> (Int, Int)
forall {a} {b}. (Num a, Num b) => (a, b) -> Char -> (a, b)
f (Int -> Int -> (Int, Int)
forall {a} {b}. a -> b -> (a, b)
pair Int
1 Int
1) (ByteString -> (Int, Int)) -> ByteString -> (Int, Int)
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.take (Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
i) ByteString
src
    where
        pair :: a -> b -> (a, b)
pair !a
a !b
b = (a
a,b
b)

        i :: Int32
i = Str -> Int32
strStart (Str -> Int32) -> Str -> Int32
forall a b. (a -> b) -> a -> b
$ Int -> Node -> Str
nodeStr Int
2 Node
n
        f :: (a, b) -> Char -> (a, b)
f (!a
line, !b
col) Char
c
            | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n' = a -> b -> (a, b)
forall {a} {b}. a -> b -> (a, b)
pair (a
linea -> a -> a
forall a. Num a => a -> a -> a
+a
1) b
1
            | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\t' = a -> b -> (a, b)
forall {a} {b}. a -> b -> (a, b)
pair a
line (b
colb -> b -> b
forall a. Num a => a -> a -> a
+b
8)
            | Bool
otherwise = a -> b -> (a, b)
forall {a} {b}. a -> b -> (a, b)
pair a
line (b
colb -> b -> b
forall a. Num a => a -> a -> a
+b
1)