git.iko.soy/typeable/hexml
on master help sign in
Improve the test framework
commita545579e094d380abe7792e432f6bd15965e58a7 authorNeil Mitchell <ndmitchell@gmail.com> dateWed 30 Nov 2016, 16:29 (10 years ago) parentf1b14d8
2 files changed+108−29
compare with master
unifiedsplit
src/Main.hs+42−5 src/Text/XML/Hexml.hs+66−24
src/Main.hs+42−5
@@ -1,12 +1,49 @@
1+{-# LANGUAGE OverloadedStrings #-}
12
23module Main(main) where
34
45import 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+ ]
618
719main :: IO ()
820main = do
9− bs <- BS.readFile "C:/Neil/notes/core.xml"
10− case parse bs of
11− Left err -> error $ show err
12− Right val -> print $ render val
21+ forM_ examples $ \(parses, src) -> do
22+ print src
23+ case documentParse src of
24+ Left err -> when parses $ fail $ "Unexpected parse failure, " ++ show err
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 @@
22
33module Text.XML.Hexml(
44 Document, Node, Attribute(..),
5− parse, render, rootNode,
5+ documentParse, documentRender, documentNode,
66 nodeName, nodeInner, nodeOuter,
77 nodeAttributes, nodeChildren, nodeContents,
88 nodeAttributeBy, nodeChildrenBy
@@ -12,11 +12,13 @@ import Control.Monad
1212import Data.Int
1313import Foreign.C
1414import Foreign.Ptr
15+import Foreign.Marshal hiding (void)
1516import Foreign.ForeignPtr
1617import Foreign.Storable
1718import System.IO.Unsafe
1819import Data.Monoid
19−import qualified Data.ByteString as BS
20+import Data.Tuple.Extra
21+import qualified Data.ByteString.Char8 as BS
2022import qualified Data.ByteString.Unsafe as BS
2123import qualified Data.ByteString.Internal as BS
2224
@@ -24,13 +26,20 @@ data CDocument
2426data CNode
2527data CAttr
2628
27−data Str = Str {start :: {-# UNPACK #-} !Int32, length :: {-# UNPACK #-} !Int32}
29+szAttr = 2 * sizeOf (undefined :: Str)
30+szNode = 5 * sizeOf (undefined :: Str)
31+
32+
33+data Str = Str {strStart :: {-# UNPACK #-} !Int32, strLength :: {-# UNPACK #-} !Int32} deriving Show
34+
35+strEnd :: Str -> Int32
36+strEnd Str{..} = strStart + strLength
2837
2938instance Storable Str where
3039 sizeOf _ = 8
3140 alignment _ = alignment (0 :: Int64)
3241 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
3443
3544foreign import ccall document_parse :: CString -> CInt -> IO (Ptr CDocument)
3645foreign import ccall document_free :: Ptr CDocument -> IO ()
@@ -39,8 +48,8 @@ foreign import ccall document_render :: Ptr CDocument -> CString -> CInt -> IO C
3948foreign import ccall document_error :: Ptr CDocument -> IO CString
4049foreign import ccall document_node :: Ptr CDocument -> IO (Ptr CNode)
4150
42−foreign import ccall node_children :: Ptr CDocument -> Ptr CNode -> Ptr CInt -> Ptr CNode
43−foreign import ccall node_attributes :: Ptr CDocument -> Ptr CNode -> Ptr CInt -> Ptr CAttr
51+foreign import ccall node_children :: Ptr CDocument -> Ptr CNode -> Ptr CInt -> IO (Ptr CNode)
52+foreign import ccall node_attributes :: Ptr CDocument -> Ptr CNode -> Ptr CInt -> IO (Ptr CAttr)
4453
4554foreign import ccall node_firstChildBy :: Ptr CDocument -> Ptr CNode -> CString -> CInt -> IO (Ptr CNode)
4655foreign 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)
5059
5160data Node = Node BS.ByteString (ForeignPtr CDocument) (Ptr CNode)
5261
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)
5469
55−parse :: BS.ByteString -> Either BS.ByteString Document
56−parse src = unsafePerformIO $ BS.unsafeUseAsCStringLen (src <> BS.singleton 0) $ \(str, len) -> do
70+
71+documentParse :: BS.ByteString -> Either BS.ByteString Document
72+documentParse src = unsafePerformIO $ BS.unsafeUseAsCStringLen (src <> BS.singleton '\0') $ \(str, len) -> do
5773 doc <- document_parse str (fromIntegral len - 1)
5874 err <- document_error doc
5975 if err /= nullPtr then do
@@ -64,40 +80,66 @@ parse src = unsafePerformIO $ BS.unsafeUseAsCStringLen (src <> BS.singleton 0) $
6480 doc <- newForeignPtr document_free_funptr doc
6581 return $ Right $ Document src doc
6682
67−render :: Document -> BS.ByteString
68−render (Document _ doc) = unsafePerformIO $ withForeignPtr doc $ \d -> do
83+documentRender :: Document -> BS.ByteString
84+documentRender (Document _ doc) = unsafePerformIO $ withForeignPtr doc $ \d -> do
6985 i <- document_render d nullPtr 0
7086 BS.create (fromIntegral i) $ \ptr -> void $ document_render d (castPtr ptr) i
7187
7288
73−rootNode :: Document -> Node
74−rootNode d@(Document src doc) = unsafePerformIO $ withForeignPtr doc $ \d -> do
89+documentNode :: Document -> Node
90+documentNode d@(Document src doc) = unsafePerformIO $ withForeignPtr doc $ \d -> do
7591 Node src doc <$> document_node d
7692
7793applyStr :: 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
7998
80−nodePeek :: Int -> Node -> BS.ByteString
81−nodePeek i (Node src doc n) = unsafePerformIO $ withForeignPtr doc $ \_ -> do
82− applyStr src <$> peekElemOff (castPtr n) i
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
103+attrPeek src doc a = unsafePerformIO $ withForeignPtr doc $ \_ -> do
104+ name <- applyStr src <$> peekElemOff (castPtr a) 0
105+ val <- applyStr src <$> peekElemOff (castPtr a) 1
106+ return $ Attribute name val
83107
84108nodeName :: Node -> BS.ByteString
85−nodeName = nodePeek 0
109+nodeName = nodeBS 0
86110
87111nodeInner :: Node -> BS.ByteString
88−nodeInner = nodePeek 1
112+nodeInner = nodeBS 1
89113
90114nodeOuter :: 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
92122
93−nodeContents :: Node -> [Either Node BS.ByteString]
94−nodeContents = undefined
123+ string start end | start == end = []
124+ | otherwise = [Left $ applyStr src $ Str start (end - start)]
125+ inner = nodeStr 1 n
126+ outers = map (nodeStr 2 &&& id) $ nodeChildren n
95127
96128nodeChildren :: Node -> [Node]
97−nodeChildren = node_children `seq` undefined
129+nodeChildren (Node src doc n) = unsafePerformIO $ withForeignPtr doc $ \d -> do
130+ alloca $ \count -> do
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]]
98135
99136nodeAttributes :: Node -> [Attribute]
100−nodeAttributes = node_attributes `seq` undefined
137+nodeAttributes (Node src doc n) = unsafePerformIO $ withForeignPtr doc $ \d -> do
138+ alloca $ \count -> do
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]]
101143
102144nodeChildrenBy :: Node -> BS.ByteString -> [Node]
103145nodeChildrenBy = node_firstChildBy `seq` node_nextChildBy `seq` undefined