diff --git a/README.md b/README.md
--- a/README.md
+++ b/README.md
@@ -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
diff --git a/src/Xeno/DOM.hs b/src/Xeno/DOM.hs
--- a/src/Xeno/DOM.hs
+++ b/src/Xeno/DOM.hs
@@ -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
diff --git a/src/Xeno/SAX.hs b/src/Xeno/SAX.hs
--- a/src/Xeno/SAX.hs
+++ b/src/Xeno/SAX.hs
@@ -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
diff --git a/src/Xeno/Types.hs b/src/Xeno/Types.hs
--- a/src/Xeno/Types.hs
+++ b/src/Xeno/Types.hs
@@ -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
diff --git a/test/Main.hs b/test/Main.hs
--- a/test/Main.hs
+++ b/test/Main.hs
@@ -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
"\n"
@@ -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 = "Content."
+ it
+ "namespaces"
+ (shouldBe
+ (Xeno.SAX.validate nsdoc)
+ True)
+ )
hexml_examples_sax :: [(Bool, ByteString)]
hexml_examples_sax =
@@ -50,6 +61,17 @@
,(True, "\nHello, world!")
]
+-- | 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."]
+ , "")
+ , ( Right [CData "This is strong but not XML tags."]
+ , "This is strong but not XML tags.]]>")
+ , ( Right [CData "A lonely ], sad isn't it?"]
+ , "")
+ ]
-- | Horrible hack. Don't try this at home.
fromRightE :: Either XenoException a -> a
diff --git a/xeno.cabal b/xeno.cabal
--- a/xeno.cabal
+++ b/xeno.cabal
@@ -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