xeno 0.1 → 0.2
raw patch · 6 files changed
+105/−21 lines, 6 files
Files
- README.md +3/−2
- src/Xeno/DOM.hs +20/−1
- src/Xeno/SAX.hs +55/−15
- src/Xeno/Types.hs +2/−1
- test/Main.hs +23/−1
- xeno.cabal +2/−1
README.md view
@@ -1,6 +1,6 @@ # xeno -[](https://travis-ci.org/ocramz/xeno)+[](https://travis-ci.org/ocramz/xeno) [](https://hackage.haskell.org/package/xeno) [](https://www.stackage.org/package/xeno) A fast event-based XML parser. @@ -14,8 +14,9 @@ * It's very fast (see speed benchmarks below). * It [cheats like Hexml does](http://neilmitchell.blogspot.co.uk/2016/12/new-xml-parser-hexml.html)- (doesn't expand entities or CDATA, or most of the XML standard).+ (doesn't expand entities, or most of the XML standard). * It's written in pure Haskell.+* CDATA is supported now. ## Performance goals
src/Xeno/DOM.hs view
@@ -46,7 +46,8 @@ data Content = Element {-# UNPACK #-}!Node | Text {-# UNPACK #-}!ByteString- deriving (Show)+ | CData {-# UNPACK #-}!ByteString+ deriving (Eq, Show) -- | Get just element children of the node (no text). children :: Node -> [Node]@@ -83,6 +84,9 @@ 0x01 -> Text (substring str (offsets ! (i + 1)) (offsets ! (i + 2))) : collect (i + 3)+ 0x03 ->+ CData (substring str (offsets ! (i + 1)) (offsets ! (i + 2))) :+ collect (i + 3) _ -> [] | otherwise = [] firstChild = go (start + 5)@@ -195,6 +199,21 @@ -- Pop the stack and return to the parent element. previousParent <- UMV.read v (parent + 1) writeRef parentRef previousParent)+ (\(PS _ cdata_start cdata_len) -> do+ let tag = 0x03+ index <- readRef 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 writeRef sizeRef (index + 3)+ do UMV.write v' index tag+ UMV.write v' (index + 1) cdata_start+ UMV.write v' (index + 2) cdata_len) str wet <- readSTRef vecRef arr <- UV.unsafeFreeze wet
src/Xeno/SAX.hs view
@@ -39,6 +39,7 @@ (\_ -> pure ()) (\_ -> pure ()) (\_ -> pure ())+ (\_ -> pure ()) s)) of Left (_ :: XenoException) -> False Right _ -> True@@ -65,6 +66,9 @@ let !level' = level - 2 put level' lift (S8.putStrLn (S8.replicate level' ' ' <> "</" <> name <> ">")))+ (\cdata -> do+ level <- get+ lift (S8.putStrLn (S8.replicate level ' ' <> "CDATA: " <> S8.pack (show cdata)))) str) (0 :: Int) @@ -75,10 +79,11 @@ -> (s -> ByteString -> s) -- ^ End of open tag. -> (s -> ByteString -> s) -- ^ Text. -> (s -> ByteString -> s) -- ^ Close tag.+ -> (s -> ByteString -> s) -- ^ CDATA. -> s -> ByteString -> Either XenoException s-fold openF attrF endOpenF textF closeF s str =+fold openF attrF endOpenF textF closeF cdataF s str = spork (execState (process@@ -87,6 +92,7 @@ (\name -> modify (\s' -> endOpenF s' name)) (\text -> modify (\s' -> textF s' text)) (\name -> modify (\s' -> closeF s' name))+ (\cdata -> modify (\s' -> cdataF s' cdata)) str) s) @@ -101,8 +107,9 @@ -> (ByteString -> m ()) -- ^ End open tag. -> (ByteString -> m ()) -- ^ Text. -> (ByteString -> m ()) -- ^ Close tag.+ -> (ByteString -> m ()) -- ^ CDATA. -> ByteString -> m ()-process openF attrF endOpenF textF closeF str = findLT 0+process openF attrF endOpenF textF closeF cdataF str = findLT 0 where findLT index = case elemIndexFrom openTagChar str index of@@ -112,26 +119,49 @@ unless (S.null text) (textF text) checkOpenComment (fromLt + 1) where text = substring str index fromLt+ -- Find open comment, CDATA or tag name. checkOpenComment index =- if s_index this 0 == bangChar &&- s_index this 1 == commentChar && s_index this 2 == commentChar- then findCommentEnd (index + 3)- else findTagName index+ if | s_index this 0 == bangChar -- !+ && s_index this 1 == commentChar -- -+ && s_index this 2 == commentChar -> -- -+ findCommentEnd (index + 3)+ | s_index this 0 == bangChar -- !+ && s_index this 1 == openAngleBracketChar -- [+ && s_index this 2 == 67 -- C+ && s_index this 3 == 68 -- D+ && s_index this 4 == 65 -- A+ && s_index this 5 == 84 -- T+ && s_index this 6 == 65 -- A+ && s_index this 7 == openAngleBracketChar -> -- [+ findCDataEnd (index + 8) (index + 8)+ | otherwise ->+ findTagName index where this = S.drop index str findCommentEnd index = case elemIndexFrom commentChar str index of- Nothing -> throw XenoParseError+ Nothing -> throw (XenoParseError "Couldn't find the closing comment dash.") Just fromDash -> if s_index this 0 == commentChar && s_index this 1 == closeTagChar then findLT (fromDash + 2) else findCommentEnd (fromDash + 1) where this = S.drop index str+ findCDataEnd cdata_start index =+ case elemIndexFrom closeAngleBracketChar str index of+ Nothing -> throw (XenoParseError "Couldn't find closing angle bracket for CDATA.")+ Just fromCloseAngleBracket ->+ if s_index str (fromCloseAngleBracket + 1) == closeAngleBracketChar+ then do+ cdataF (substring str cdata_start fromCloseAngleBracket)+ findLT (fromCloseAngleBracket + 3) -- Start after ]]>+ else+ -- We only found one ], that means that we need to keep searching.+ findCDataEnd cdata_start (fromCloseAngleBracket + 1) findTagName index0 = let spaceOrCloseTag = parseName str index in if | s_index str index0 == questionChar -> case elemIndexFrom closeTagChar str spaceOrCloseTag of- Nothing -> throw XenoParseError+ Nothing -> throw (XenoParseError "Couldn't find the end of the tag.") Just fromGt -> do findLT (fromGt + 1) | s_index str spaceOrCloseTag == closeTagChar ->@@ -174,7 +204,7 @@ str (quoteIndex + 1) of Nothing ->- throw XenoParseError+ throw (XenoParseError "Couldn't find the matching quote character.") Just endQuoteIndex -> do attrF (substring str index afterAttrName)@@ -183,8 +213,8 @@ (quoteIndex + 1) (endQuoteIndex)) findAttributes (endQuoteIndex + 1)- else throw XenoParseError- else throw XenoParseError+ else throw (XenoParseError ("Expected ' or \", got: " <> S.singleton usedChar))+ else throw (XenoParseError ("Expected =, got: " <> S.singleton (s_index str afterAttrName) <> " at character index: " <> (S8.pack . show) afterAttrName)) where index = skipSpaces str index0 {-# INLINE process #-}@@ -193,14 +223,16 @@ (ByteString -> ByteString -> Identity ()) -> (ByteString -> Identity ()) -> (ByteString -> Identity ()) ->- (ByteString -> Identity ()) -> ByteString -> Identity ()+ (ByteString -> Identity ()) ->+ (ByteString -> Identity ()) -> ByteString -> Identity () #-} {-# SPECIALISE process :: (ByteString -> IO ()) -> (ByteString -> ByteString -> IO ()) -> (ByteString -> IO ()) -> (ByteString -> IO ()) ->- (ByteString -> IO ()) -> ByteString -> IO ()+ (ByteString -> IO ()) ->+ (ByteString -> IO ()) -> ByteString -> IO () #-} --------------------------------------------------------------------------------@@ -253,7 +285,7 @@ -- | Is the character a valid tag name constituent? isNameChar :: Word8 -> Bool isNameChar c =- (c >= 97 && c <= 122) || (c >= 65 && c <= 90) || c == 95 || c == 45+ (c >= 97 && c <= 122) || (c >= 65 && c <= 90) || c == 95 || c == 45 || c == 58 {-# INLINE isNameChar #-} -- | Char for '\''.@@ -280,7 +312,7 @@ bangChar :: Word8 bangChar = 33 --- | Open tag character.+-- | The dash character. commentChar :: Word8 commentChar = 45 -- '-' @@ -291,3 +323,11 @@ -- | Close tag character. closeTagChar :: Word8 closeTagChar = 62 -- '>'++-- | Open angle bracket character.+openAngleBracketChar :: Word8+openAngleBracketChar = 91++-- | Close angle bracket character.+closeAngleBracketChar :: Word8+closeAngleBracketChar = 93
src/Xeno/Types.hs view
@@ -7,12 +7,13 @@ import Control.DeepSeq import Control.Exception+import Data.ByteString (ByteString) import Data.Typeable import GHC.Generics data XenoException = XenoStringIndexProblem- | XenoParseError+ | XenoParseError ByteString | XenoExpectRootNode deriving (Show, Typeable, NFData, Generic) instance Exception XenoException where displayException = show
test/Main.hs view
@@ -25,6 +25,9 @@ (do mapM_ (\(v, i) -> it (show i) (shouldBe (Xeno.SAX.validate i) v)) hexml_examples_sax+ mapM_+ (\(v, i) -> it (show i) (shouldBe (either (Left . show) (Right . id) (contents <$> Xeno.DOM.parse i)) v))+ cdata_tests let doc = parse "<root><test id=\"1\" extra=\"2\" />\n<test id=\"2\" /><b><test id=\"3\" /></b><test id=\"4\" /><test /></root>"@@ -37,7 +40,15 @@ "attributes" (shouldBe (attributes (head (children $ fromRightE doc)))- [("id", "1"), ("extra", "2")]))+ [("id", "1"), ("extra", "2")])+ -- If this works without crashing we're happy.+ let nsdoc = "<ns:tag os:attr=\"Namespaced attribute value\">Content.</ns:tag>"+ it+ "namespaces"+ (shouldBe+ (Xeno.SAX.validate nsdoc)+ True)+ ) hexml_examples_sax :: [(Bool, ByteString)] hexml_examples_sax =@@ -50,6 +61,17 @@ ,(True, "<?xml version=\"1.1\"?>\n<greeting>Hello, world!</greeting>") ] +-- | We want to make sure that the parser doesn't jump out of the CDATA+-- area prematurely because it encounters a single ].+cdata_tests :: [(Either a [Content], ByteString)]+cdata_tests =+ [ ( Right [CData "Oneliner CDATA."]+ , "<test><![CDATA[Oneliner CDATA.]]></test>")+ , ( Right [CData "<strong>This is strong but not XML tags.</strong>"]+ , "<test><![CDATA[<strong>This is strong but not XML tags.</strong>]]></test>")+ , ( Right [CData "A lonely ], sad isn't it?"]+ , "<test><![CDATA[A lonely ], sad isn't it?]]></test>")+ ] -- | Horrible hack. Don't try this at home. fromRightE :: Either XenoException a -> a
xeno.cabal view
@@ -1,6 +1,7 @@ name: xeno-version: 0.1+version: 0.2 synopsis: A fast event-based XML parser in pure Haskell+description: Please see README.md build-type: Simple category: XML, Parser cabal-version: >=1.10