git.iko.soy/typeable/hexml
on master help sign in
Improve the test framework
a545579Neil Mitchell
src/Main.hs+42−5
compare with master
unifiedsplit
@@ -1,12 +1,49 @@
1+{-# LANGUAGE OverloadedStrings #-}
1
2
2module Main(main) where
3module Main(main) where
3
4
4import Text.XML.Hexml
5import Text.XML.Hexml
5−import qualified Data.ByteString as BS
6+import qualified Data.ByteString.Char8 as BS
7+import Control.Monad
8+import Data.Monoid
9+import Data.Char
10+
11+
12+examples :: [(Bool, BS.ByteString)]
13+examples =
14+ [(True, "<test id=bob>here<extra/>there</test>")
15+ ,(True, "<test /><close />")
16+ ,(True, "<test id=\"bob value\" another-attr=\"test with <\">here </test> more text at the end<close />")
17+ ]
6
18
7main :: IO ()
19main :: IO ()
8main = do
20main = do
9− bs <- BS.readFile "C:/Neil/notes/core.xml"
21+ forM_ examples $ \(parses, src) -> do
10− case parse bs of
22+ print src
23+ case documentParse src of
11− Left err -> error $ show err
24+ Left err -> when parses $ fail $ "Unexpected parse failure, " ++ show err
12− Right val -> print $ render val
25+ Right doc -> do
26+ unless parses $ fail "Unexpected parse success"
27+ let r = documentRender doc
28+ print r
29+ print $ rerender doc
30+ when (r /= rerender doc) $ fail "Different rerender"
31+ let Right d = documentParse r
32+ when (r /= documentRender d) $ fail "Different after rerendering"
33+
34+
35+rerender :: Document -> BS.ByteString
36+rerender = contents . documentNode
37+ where
38+ contents x = BS.concat $ map (either validStr node) $ nodeContents x
39+ node x = "<" <> BS.unwords (validName (nodeName x) : map attr (nodeAttributes x)) <> ">" <>
40+ contents x <>
41+ "</" <> nodeName x <> ">"
42+ attr (Attribute a b) = validName a <> "=\"" <> validAttr b <> "\""
43+
44+ validName x | BS.all (\x -> isAlpha x) x = x
45+ | otherwise = error "Invalid name"
46+ validAttr x | BS.notElem '\"' x = x
47+ | otherwise = error "Invalid attribute"
48+ validStr x | BS.notElem '<' x = x
49+ | otherwise = error $ show ("Invalid string", x)
src/Text/XML/Hexml.hs+66−24
@@ -2,7 +2,7 @@
2
2
3module Text.XML.Hexml(
3module Text.XML.Hexml(
4 Document, Node, Attribute(..),
4 Document, Node, Attribute(..),
5− parse, render, rootNode,
5+ documentParse, documentRender, documentNode,
6 nodeName, nodeInner, nodeOuter,
6 nodeName, nodeInner, nodeOuter,
7 nodeAttributes, nodeChildren, nodeContents,
7 nodeAttributes, nodeChildren, nodeContents,
8 nodeAttributeBy, nodeChildrenBy
8 nodeAttributeBy, nodeChildrenBy
@@ -12,11 +12,13 @@ import Control.Monad
12import Data.Int
12import Data.Int
13import Foreign.C
13import Foreign.C
14import Foreign.Ptr
14import Foreign.Ptr
15+import Foreign.Marshal hiding (void)
15import Foreign.ForeignPtr
16import Foreign.ForeignPtr
16import Foreign.Storable
17import Foreign.Storable
17import System.IO.Unsafe
18import System.IO.Unsafe
18import Data.Monoid
19import Data.Monoid
20+import Data.Tuple.Extra
19−import qualified Data.ByteString as BS
21+import qualified Data.ByteString.Char8 as BS
20import qualified Data.ByteString.Unsafe as BS
22import qualified Data.ByteString.Unsafe as BS
21import qualified Data.ByteString.Internal as BS
23import qualified Data.ByteString.Internal as BS
22
24
@@ -24,13 +26,20 @@ data CDocument
24data CNode
26data CNode
25data CAttr
27data CAttr
26
28
29+szAttr = 2 * sizeOf (undefined :: Str)
30+szNode = 5 * sizeOf (undefined :: Str)
31+
32+
27−data Str = Str {start :: {-# UNPACK #-} !Int32, length :: {-# UNPACK #-} !Int32}
33+data Str = Str {strStart :: {-# UNPACK #-} !Int32, strLength :: {-# UNPACK #-} !Int32} deriving Show
34+
35+strEnd :: Str -> Int32
36+strEnd Str{..} = strStart + strLength
28
37
29instance Storable Str where
38instance Storable Str where
30 sizeOf _ = 8
39 sizeOf _ = 8
31 alignment _ = alignment (0 :: Int64)
40 alignment _ = alignment (0 :: Int64)
32 peek p = Str <$> peekByteOff p 0 <*> peekByteOff p 4
41 peek p = Str <$> peekByteOff p 0 <*> peekByteOff p 4
33− poke p Str{..} = pokeByteOff p 0 start >> pokeByteOff p 4 length
42+ poke p Str{..} = pokeByteOff p 0 strStart >> pokeByteOff p 4 strLength
34
43
35foreign import ccall document_parse :: CString -> CInt -> IO (Ptr CDocument)
44foreign import ccall document_parse :: CString -> CInt -> IO (Ptr CDocument)
36foreign import ccall document_free :: Ptr CDocument -> IO ()
45foreign import ccall document_free :: Ptr CDocument -> IO ()
@@ -39,8 +48,8 @@ foreign import ccall document_render :: Ptr CDocument -> CString -> CInt -> IO C
39foreign import ccall document_error :: Ptr CDocument -> IO CString
48foreign import ccall document_error :: Ptr CDocument -> IO CString
40foreign import ccall document_node :: Ptr CDocument -> IO (Ptr CNode)
49foreign import ccall document_node :: Ptr CDocument -> IO (Ptr CNode)
41
50
42−foreign import ccall node_children :: Ptr CDocument -> Ptr CNode -> Ptr CInt -> Ptr CNode
51+foreign import ccall node_children :: Ptr CDocument -> Ptr CNode -> Ptr CInt -> IO (Ptr CNode)
43−foreign import ccall node_attributes :: Ptr CDocument -> Ptr CNode -> Ptr CInt -> Ptr CAttr
52+foreign import ccall node_attributes :: Ptr CDocument -> Ptr CNode -> Ptr CInt -> IO (Ptr CAttr)
44
53
45foreign import ccall node_firstChildBy :: Ptr CDocument -> Ptr CNode -> CString -> CInt -> IO (Ptr CNode)
54foreign import ccall node_firstChildBy :: Ptr CDocument -> Ptr CNode -> CString -> CInt -> IO (Ptr CNode)
46foreign import ccall node_nextChildBy :: Ptr CDocument -> Ptr CNode -> Ptr CNode -> CString -> CInt -> IO (Ptr CNode)
55foreign import ccall node_nextChildBy :: Ptr CDocument -> Ptr CNode -> Ptr CNode -> CString -> CInt -> IO (Ptr CNode)
@@ -50,10 +59,17 @@ data Document = Document BS.ByteString (ForeignPtr CDocument)
50
59
51data Node = Node BS.ByteString (ForeignPtr CDocument) (Ptr CNode)
60data Node = Node BS.ByteString (ForeignPtr CDocument) (Ptr CNode)
52
61
53−data Attribute = Attribute BS.ByteString BS.ByteString
62+data Attribute = Attribute BS.ByteString BS.ByteString deriving Show
63+
64+instance Show Document where
65+ show d = "Document " ++ show (BS.unpack $ nodeOuter $ documentNode d)
66+
67+instance Show Node where
68+ show d = "Node " ++ show (BS.unpack $ nodeOuter d)
54
69
70+
55−parse :: BS.ByteString -> Either BS.ByteString Document
71+documentParse :: BS.ByteString -> Either BS.ByteString Document
56−parse src = unsafePerformIO $ BS.unsafeUseAsCStringLen (src <> BS.singleton 0) $ \(str, len) -> do
72+documentParse src = unsafePerformIO $ BS.unsafeUseAsCStringLen (src <> BS.singleton '\0') $ \(str, len) -> do
57 doc <- document_parse str (fromIntegral len - 1)
73 doc <- document_parse str (fromIntegral len - 1)
58 err <- document_error doc
74 err <- document_error doc
59 if err /= nullPtr then do
75 if err /= nullPtr then do
@@ -64,40 +80,66 @@ parse src = unsafePerformIO $ BS.unsafeUseAsCStringLen (src <> BS.singleton 0) $
64 doc <- newForeignPtr document_free_funptr doc
80 doc <- newForeignPtr document_free_funptr doc
65 return $ Right $ Document src doc
81 return $ Right $ Document src doc
66
82
67−render :: Document -> BS.ByteString
83+documentRender :: Document -> BS.ByteString
68−render (Document _ doc) = unsafePerformIO $ withForeignPtr doc $ \d -> do
84+documentRender (Document _ doc) = unsafePerformIO $ withForeignPtr doc $ \d -> do
69 i <- document_render d nullPtr 0
85 i <- document_render d nullPtr 0
70 BS.create (fromIntegral i) $ \ptr -> void $ document_render d (castPtr ptr) i
86 BS.create (fromIntegral i) $ \ptr -> void $ document_render d (castPtr ptr) i
71
87
72
88
73−rootNode :: Document -> Node
89+documentNode :: Document -> Node
74−rootNode d@(Document src doc) = unsafePerformIO $ withForeignPtr doc $ \d -> do
90+documentNode d@(Document src doc) = unsafePerformIO $ withForeignPtr doc $ \d -> do
75 Node src doc <$> document_node d
91 Node src doc <$> document_node d
76
92
77applyStr :: BS.ByteString -> Str -> BS.ByteString
93applyStr :: BS.ByteString -> Str -> BS.ByteString
78−applyStr bs Str{..} = BS.take (fromIntegral length) $ BS.drop (fromIntegral start) bs
94+applyStr bs Str{..} = BS.take (fromIntegral strLength) $ BS.drop (fromIntegral strStart) bs
95+
96+nodeStr :: Int -> Node -> Str
97+nodeStr i (Node src doc n) = unsafePerformIO $ withForeignPtr doc $ \_ -> peekElemOff (castPtr n) i
79
98
80−nodePeek :: Int -> Node -> BS.ByteString
99+nodeBS :: Int -> Node -> BS.ByteString
100+nodeBS i node@(Node src doc n) = applyStr src $ nodeStr i node
101+
102+attrPeek :: BS.ByteString -> ForeignPtr CDocument -> Ptr CAttr -> Attribute
81−nodePeek i (Node src doc n) = unsafePerformIO $ withForeignPtr doc $ \_ -> do
103+attrPeek src doc a = unsafePerformIO $ withForeignPtr doc $ \_ -> do
104+ name <- applyStr src <$> peekElemOff (castPtr a) 0
82− applyStr src <$> peekElemOff (castPtr n) i
105+ val <- applyStr src <$> peekElemOff (castPtr a) 1
106+ return $ Attribute name val
83
107
84nodeName :: Node -> BS.ByteString
108nodeName :: Node -> BS.ByteString
85−nodeName = nodePeek 0
109+nodeName = nodeBS 0
86
110
87nodeInner :: Node -> BS.ByteString
111nodeInner :: Node -> BS.ByteString
88−nodeInner = nodePeek 1
112+nodeInner = nodeBS 1
89
113
90nodeOuter :: Node -> BS.ByteString
114nodeOuter :: Node -> BS.ByteString
91−nodeOuter = nodePeek 2
115+nodeOuter = nodeBS 2
116+
117+nodeContents :: Node -> [Either BS.ByteString Node]
118+nodeContents n@(Node src _ _) = f (strStart inner) outers
119+ where
120+ f i [] = string i (strEnd inner) ++ []
121+ f i ((x, n):xs) = string i (strStart x) ++ Right n : f (strEnd x) xs
92
122
93−nodeContents :: Node -> [Either Node BS.ByteString]
123+ string start end | start == end = []
94−nodeContents = undefined
124+ | otherwise = [Left $ applyStr src $ Str start (end - start)]
125+ inner = nodeStr 1 n
126+ outers = map (nodeStr 2 &&& id) $ nodeChildren n
95
127
96nodeChildren :: Node -> [Node]
128nodeChildren :: Node -> [Node]
129+nodeChildren (Node src doc n) = unsafePerformIO $ withForeignPtr doc $ \d -> do
130+ alloca $ \count -> do
97−nodeChildren = node_children `seq` undefined
131+ res <- node_children d n count
132+ count <- fromIntegral <$> peek count
133+ let sz = 2 * szNode
134+ return [Node src doc $ plusPtr res $ i*sz | i <- [0..count-1]]
98
135
99nodeAttributes :: Node -> [Attribute]
136nodeAttributes :: Node -> [Attribute]
137+nodeAttributes (Node src doc n) = unsafePerformIO $ withForeignPtr doc $ \d -> do
138+ alloca $ \count -> do
100−nodeAttributes = node_attributes `seq` undefined
139+ res <- node_attributes d n count
140+ count <- fromIntegral <$> peek count
141+ let sz = 2 * szAttr
142+ return [attrPeek src doc (plusPtr res $ i*sz) | i <- [0..count-1]]
101
143
102nodeChildrenBy :: Node -> BS.ByteString -> [Node]
144nodeChildrenBy :: Node -> BS.ByteString -> [Node]
103nodeChildrenBy = node_firstChildBy `seq` node_nextChildBy `seq` undefined
145nodeChildrenBy = node_firstChildBy `seq` node_nextChildBy `seq` undefined