git.iko.soy/typeable/hexml
on 9a458ff help sign in
typeable/hexml/src/Text/XML/Hexml.hs
205 lines 8.6 kB history raw
1{-# LANGUAGE RecordWildCards, BangPatterns #-}
3-- | A module for fast first-approximation parsing of XML.
4-- Note that entities, e.g. @&@, are not expanded.
5module Text.XML.Hexml(
6 Node, Attribute(..),
7 parse, render,
8 location, name, inner, outer,
9 attributes, children, contents,
10 attributeBy, childrenBy
11 ) where
13import Control.Applicative
14import Control.Monad
15import Data.Int
16import Foreign.C
17import Foreign.Ptr
18import Foreign.Marshal hiding (void)
19import Foreign.ForeignPtr
20import Foreign.Storable
21import System.IO.Unsafe
22import Data.Monoid
23import Data.Tuple.Extra
24import qualified Data.ByteString.Char8 as BS
25import qualified Data.ByteString.Unsafe as BS
26import qualified Data.ByteString.Internal as BS
27import Prelude
29data CDocument
30data CNode
31data CAttr
33szAttr = 2 * sizeOf (undefined :: Str)
34szNode = 5 * sizeOf (undefined :: Str)
37data Str = Str {strStart :: {-# UNPACK #-} !Int32, strLength :: {-# UNPACK #-} !Int32} deriving Show
39strEnd :: Str -> Int32
40strEnd Str{..} = strStart + strLength
42instance Storable Str where
43 sizeOf _ = 8
44 alignment _ = alignment (0 :: Int64)
45 peek p = Str <$> peekByteOff p 0 <*> peekByteOff p 4
46 poke p Str{..} = pokeByteOff p 0 strStart >> pokeByteOff p 4 strLength
48foreign import ccall hexml_document_parse :: CString -> CInt -> IO (Ptr CDocument)
49foreign import ccall hexml_document_free :: Ptr CDocument -> IO ()
50foreign import ccall "&hexml_document_free" hexml_document_free_funptr :: FunPtr (Ptr CDocument -> IO ())
51foreign import ccall hexml_node_render :: Ptr CDocument -> Ptr CNode -> CString -> CInt -> IO CInt
52foreign import ccall unsafe hexml_document_error :: Ptr CDocument -> IO CString
53foreign import ccall unsafe hexml_document_node :: Ptr CDocument -> IO (Ptr CNode)
55foreign import ccall unsafe hexml_node_children :: Ptr CDocument -> Ptr CNode -> Ptr CInt -> IO (Ptr CNode)
56foreign import ccall unsafe hexml_node_attributes :: Ptr CDocument -> Ptr CNode -> Ptr CInt -> IO (Ptr CAttr)
58foreign import ccall unsafe hexml_node_child :: Ptr CDocument -> Ptr CNode -> Ptr CNode -> CString -> CInt -> IO (Ptr CNode)
59foreign import ccall unsafe hexml_node_attribute :: Ptr CDocument -> Ptr CNode -> CString -> CInt -> IO (Ptr CAttr)
61-- | A node in an XML document, created by 'parse', then calling functions such
62-- as 'children' on that initial 'Node'.
63data Node = Node BS.ByteString (ForeignPtr CDocument) (Ptr CNode)
65-- | An XML attribute, comprising of a name and a value. As an example,
66-- @hello=\"world\"@ would produce @Attribute \"hello\" \"world\"@.
67data Attribute = Attribute
68 {attributeName :: BS.ByteString
69 ,attributeValue :: BS.ByteString
70 } deriving (Show, Eq, Ord)
72instance Show Node where
73 show d = "Node " ++ show (BS.unpack $ outer d)
76touchBS :: BS.ByteString -> IO ()
77touchBS = touchForeignPtr . fst3 . BS.toForeignPtr
80-- | Parse a ByteString as an XML document, returning a 'Left' error message, or a 'Right' document.
81-- Note that the returned node will have a 'name' of @\"\"@, no 'attributes', and 'contents' as per the document.
82-- Often the first child will be the @\<?xml ... ?\>@ element. For documents which comprise an XML node and a single
83-- root element, use @'children' n !! 1@.
84parse :: BS.ByteString -> Either BS.ByteString Node
85parse src = do
86 let src0 = src <> BS.singleton '\0'
87 unsafePerformIO $ BS.unsafeUseAsCStringLen src0 $ \(str, len) -> do
88 doc <- hexml_document_parse str (fromIntegral len - 1)
89 err <- hexml_document_error doc
90 if err /= nullPtr then do
91 bs <- BS.packCString =<< hexml_document_error doc
92 hexml_document_free doc
93 return $ Left bs
94 else do
95 node <- hexml_document_node doc
96 doc <- newForeignPtr hexml_document_free_funptr doc
97 return $ Right $ Node src0 doc node
99-- | Given a node, rerender it to something with an equivalent parse tree.
100-- Mostly useful for debugging - if you want the real source document use 'outer' instead.
101render :: Node -> BS.ByteString
102render (Node src doc n) = unsafePerformIO $ withForeignPtr doc $ \d -> do
103 i <- hexml_node_render d n nullPtr 0
104 res <- BS.create (fromIntegral i) $ \ptr -> void $ hexml_node_render d n (castPtr ptr) i
105 touchBS src
106 return res
108applyStr :: BS.ByteString -> Str -> BS.ByteString
109applyStr bs Str{..} = BS.take (fromIntegral strLength) $ BS.drop (fromIntegral strStart) bs
111nodeStr :: Int -> Node -> Str
112nodeStr i (Node src doc n) = unsafePerformIO $ withForeignPtr doc $ \_ -> peekElemOff (castPtr n) i
114nodeBS :: Int -> Node -> BS.ByteString
115nodeBS i node@(Node src doc n) = applyStr src $ nodeStr i node
117attrPeek :: BS.ByteString -> ForeignPtr CDocument -> Ptr CAttr -> Attribute
118attrPeek src doc a = unsafePerformIO $ withForeignPtr doc $ \_ -> do
119 name <- applyStr src <$> peekElemOff (castPtr a) 0
120 val <- applyStr src <$> peekElemOff (castPtr a) 1
121 return $ Attribute name val
123-- | Get the name of a node, e.g. @\<test /\>@ produces @\"test\"@.
124name :: Node -> BS.ByteString
125name = nodeBS 0
127-- | Get the inner text, from inside the tag, e.g. @\<test /\>@ produces @\"\"@
128-- and @\<test\>hello\</test\>@ produces @\"hello\"@.
129-- The result will have identical layout/spacing to the source document.
130inner :: Node -> BS.ByteString
131inner = nodeBS 1
133-- | Get the outer text, including the tag itself, e.g. @\<test /\>@ produces @\"\<test /\>\"@
134-- and @\<test\>hello\</test\>@ produces @\"\<test\>hello\</test\>\"@.
135-- The result will have identical layout/spacing to the source document.
136outer :: Node -> BS.ByteString
137outer = nodeBS 2
139-- | Get the contents of a node, including both the content strings (as 'Left', never blank) and
140-- the direct child nodes (as 'Right').
141-- If you only want the child nodes, use 'children'.
142contents :: Node -> [Either BS.ByteString Node]
143contents n@(Node src _ _) = f (strStart inner) outers
144 where
145 f i [] = string i (strEnd inner) ++ []
146 f i ((x, n):xs) = string i (strStart x) ++ Right n : f (strEnd x) xs
148 string start end | start == end = []
149 | otherwise = [Left $ applyStr src $ Str start (end - start)]
150 inner = nodeStr 1 n
151 outers = map (nodeStr 2 &&& id) $ children n
153-- | Get the direct child nodes of this node.
154children :: Node -> [Node]
155children (Node src doc n) = unsafePerformIO $ withForeignPtr doc $ \d ->
156 alloca $ \count -> do
157 res <- hexml_node_children d n count
158 count <- fromIntegral <$> peek count
159 return [Node src doc $ plusPtr res $ i*szNode | i <- [0..count-1]]
161-- | Get the attributes of this node.
162attributes :: Node -> [Attribute]
163attributes (Node src doc n) = unsafePerformIO $ withForeignPtr doc $ \d ->
164 alloca $ \count -> do
165 res <- hexml_node_attributes d n count
166 count <- fromIntegral <$> peek count
167 return [attrPeek src doc $ plusPtr res $ i*szAttr | i <- [0..count-1]]
169-- | Get the direct children of this node which have a specific name.
170-- A more efficient version of:
171--
172-- > childrenBy p s = filter (\n -> name n == s) $ children p
173childrenBy :: Node -> BS.ByteString -> [Node]
174childrenBy (Node src doc n) str = go nullPtr
175 where
176 go old = unsafePerformIO $ withForeignPtr doc $ \d ->
177 BS.unsafeUseAsCStringLen str $ \(bs, len) -> do
178 r <- hexml_node_child d n old bs $ fromIntegral len
179 touchBS src
180 return $ if r == nullPtr then [] else Node src doc r : go r
182-- | Get the first attribute of this node which has a specific name, if there is one.
183-- A more efficient version of:
184--
185-- > attributeBy n s = listToMaybe $ filter (\(Attribute a _) -> a == s $ attributes n
186attributeBy :: Node -> BS.ByteString -> Maybe Attribute
187attributeBy (Node src doc n) str = unsafePerformIO $ withForeignPtr doc $ \d ->
188 BS.unsafeUseAsCStringLen str $ \(bs, len) -> do
189 r <- hexml_node_attribute d n bs $ fromIntegral len
190 touchBS src
191 return $ if r == nullPtr then Nothing else Just $ attrPeek src doc r
193-- | Find the starting location of a node, the @<@ character.
194-- The first character will be reported as @(line 1,column 1)@, because thats
195-- how error messages typically do it.
196location :: Node -> (Int, Int)
197location n@(Node src _ _) = BS.foldl' f (pair 1 1) $ BS.take (fromIntegral i) src
198 where
199 pair !a !b = (a,b)
201 i = strStart $ nodeStr 2 n
202 f (!line, !col) c
203 | c == '\n' = pair (line+1) 1
204 | c == '\t' = pair line (col+8)
205 | otherwise = pair line (col+1)