diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown new file mode 100644 --- /dev/null +++ b/CHANGELOG.markdown @@ -0,0 +1,2 @@ +0.1 +First Hackage release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +Copyright (c) 2016-2017, Chris Done + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +* Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +* Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +* Neither the name of hindent nor the names of its contributors may be + used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL CHRIS DONE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR +BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN +IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,188 @@ +# xeno + +[![Build Status](https://travis-ci.org/ocramz/xeno.png)](https://travis-ci.org/ocramz/xeno) + +A fast event-based XML parser. + +[Blog post](http://chrisdone.com/posts/fast-haskell-c-parsing-xml). + +## Features + +* It's a SAX-style/fold parser which triggers events for open/close + tags, attributes, text, etc. +* It uses low memory (see memory benchmarks below). +* 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). +* It's written in pure Haskell. + + +## Performance goals + +The [hexml](https://github.com/ndmitchell/hexml) Haskell library uses +an XML parser written in C, so that is the baseline we're trying to +beat or match roughly. + +![Imgur](http://i.imgur.com/XgdZoQ9.png) + +The `Xeno.SAX` module is faster than Hexml for simply walking the +document. Hexml actually does more work, allocating a DOM. `Xeno.DOM` +is slighly slower or faster than Hexml depending on the document, +although it is 2x slower on a 211KB document. + +Memory benchmarks for Xeno: + + Case Bytes GCs Check + 4kb/xeno/sax 2,376 0 OK + 31kb/xeno/sax 1,824 0 OK + 211kb/xeno/sax 56,832 0 OK + 4kb/xeno/dom 11,360 0 OK + 31kb/xeno/dom 10,352 0 OK + 211kb/xeno/dom 1,082,816 0 OK + +I memory benchmarked Hexml, but most of its allocation happens in C, +which GHC doesn't track. So the data wasn't useful to compare. + +Speed benchmarks: + + benchmarking 4KB/hexml/dom + time 6.317 μs (6.279 μs .. 6.354 μs) + 1.000 R² (1.000 R² .. 1.000 R²) + mean 6.333 μs (6.307 μs .. 6.362 μs) + std dev 97.15 ns (77.15 ns .. 125.3 ns) + variance introduced by outliers: 13% (moderately inflated) + + benchmarking 4KB/xeno/sax + time 5.152 μs (5.131 μs .. 5.179 μs) + 1.000 R² (1.000 R² .. 1.000 R²) + mean 5.139 μs (5.128 μs .. 5.161 μs) + std dev 58.02 ns (41.25 ns .. 85.41 ns) + + benchmarking 4KB/xeno/dom + time 10.93 μs (10.83 μs .. 11.14 μs) + 0.994 R² (0.983 R² .. 0.999 R²) + mean 11.35 μs (11.12 μs .. 11.91 μs) + std dev 1.188 μs (458.7 ns .. 2.148 μs) + variance introduced by outliers: 87% (severely inflated) + + benchmarking 31KB/hexml/dom + time 9.405 μs (9.348 μs .. 9.480 μs) + 0.999 R² (0.998 R² .. 0.999 R²) + mean 9.745 μs (9.599 μs .. 10.06 μs) + std dev 745.3 ns (598.6 ns .. 902.4 ns) + variance introduced by outliers: 78% (severely inflated) + + benchmarking 31KB/xeno/sax + time 2.736 μs (2.723 μs .. 2.753 μs) + 1.000 R² (1.000 R² .. 1.000 R²) + mean 2.757 μs (2.742 μs .. 2.791 μs) + std dev 76.93 ns (43.62 ns .. 136.1 ns) + variance introduced by outliers: 35% (moderately inflated) + + benchmarking 31KB/xeno/dom + time 5.767 μs (5.735 μs .. 5.814 μs) + 0.999 R² (0.999 R² .. 1.000 R²) + mean 5.759 μs (5.728 μs .. 5.810 μs) + std dev 127.3 ns (79.02 ns .. 177.2 ns) + variance introduced by outliers: 24% (moderately inflated) + + benchmarking 211KB/hexml/dom + time 260.3 μs (259.8 μs .. 260.8 μs) + 1.000 R² (1.000 R² .. 1.000 R²) + mean 259.9 μs (259.7 μs .. 260.3 μs) + std dev 959.9 ns (821.8 ns .. 1.178 μs) + + benchmarking 211KB/xeno/sax + time 249.2 μs (248.5 μs .. 250.1 μs) + 1.000 R² (1.000 R² .. 1.000 R²) + mean 251.5 μs (250.6 μs .. 253.0 μs) + std dev 3.944 μs (3.032 μs .. 5.345 μs) + + benchmarking 211KB/xeno/dom + time 543.1 μs (539.4 μs .. 547.0 μs) + 0.999 R² (0.999 R² .. 1.000 R²) + mean 550.0 μs (545.3 μs .. 553.6 μs) + std dev 14.39 μs (12.45 μs .. 17.12 μs) + variance introduced by outliers: 17% (moderately inflated) + +## DOM Example + +Easy as running the parse function: + +``` haskell +> parse "

hisuphi

" +Right + (Node + "p" + [("key", "val"), ("x", "foo"), ("k", "")] + [ Element (Node "a" [] [Element (Node "hr" [] []), Text "hi"]) + , Element (Node "b" [] [Text "sup"]) + , Text "hi" + ]) +``` + +## SAX Example + +Quickly dumping XML: + +``` haskell +> let input = "TextHello, World!Content!Trailing." +> dump input +"Text" + + "Hello, World!" + + + + "Content!" + + +"Trailing." +``` + +Folding over XML: + +``` haskell +> fold const (\m _ _ -> m + 1) const const const 0 input -- Count elements. +Right 2 +``` + +``` haskell +> fold (\m _ -> m + 1) (\m _ _ -> m) const const const 0 input -- Count attributes. +Right 3 +``` + +Most general XML processor: + +``` haskell +process + :: Monad m + => (ByteString -> m ()) -- ^ Open tag. + -> (ByteString -> ByteString -> m ()) -- ^ Tag attribute. + -> (ByteString -> m ()) -- ^ End open tag. + -> (ByteString -> m ()) -- ^ Text. + -> (ByteString -> m ()) -- ^ Close tag. + -> ByteString -- ^ Input string. + -> m () +``` + +You can use any monad you want. IO, State, etc. For example, `fold` is +implemented like this: + +``` haskell +fold openF attrF endOpenF textF closeF s str = + execState + (process + (\name -> modify (\s' -> openF s' name)) + (\key value -> modify (\s' -> attrF s' key value)) + (\name -> modify (\s' -> endOpenF s' name)) + (\text -> modify (\s' -> textF s' text)) + (\name -> modify (\s' -> closeF s' name)) + str) + s +``` + +The `process` is marked as INLINE, which means use-sites of it will +inline, and your particular monad's type will be potentially erased +for great performance. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/bench/Memory.hs b/bench/Memory.hs new file mode 100644 --- /dev/null +++ b/bench/Memory.hs @@ -0,0 +1,32 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE BangPatterns #-} + +-- | Benchmark memory allocations. + +module Main where + +import Control.DeepSeq +import qualified Data.ByteString as S +import qualified Text.XML.Hexml as Hexml +import Weigh +import qualified Xeno.DOM +import qualified Xeno.SAX + +main :: IO () +main = do + f4kb <- S.readFile "data/books-4kb.xml" + f31kb <- S.readFile "data/text-31kb.xml" + f211kb <- S.readFile "data/fabricated-211kb.xml" + mainWith + (do func "4kb/hexml/dom" Hexml.parse f4kb + func "4kb/xeno/sax" Xeno.SAX.validate f4kb + func "4kb/xeno/dom" Xeno.DOM.parse f4kb + func "31kb/hexml/dom" Hexml.parse f31kb + func "31kb/xeno/sax" Xeno.SAX.validate f31kb + func "31kb/xeno/dom" Xeno.DOM.parse f31kb + func "211kb/hexml/dom" Hexml.parse f211kb + func "211kb/xeno/sax" Xeno.SAX.validate f211kb + func "211kb/xeno/dom" Xeno.DOM.parse f211kb) + +instance NFData Hexml.Node where + rnf !_ = () diff --git a/bench/Speed.hs b/bench/Speed.hs new file mode 100644 --- /dev/null +++ b/bench/Speed.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE StandaloneDeriving, DeriveGeneric #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | Benchmark speed. + +module Main where + +import Control.DeepSeq +import Criterion +import Criterion.Main +import Data.ByteString (ByteString) +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import GHC.Generics +import qualified Text.XML.Expat.SAX as Hexpat +import qualified Text.XML.Expat.Tree as HexpatTree +import qualified Text.XML.Hexml as Hexml +import Text.XML.Light as XML +import Text.XML.Light.Input as XML +import qualified Xeno.SAX +import qualified Xeno.DOM +#ifdef LIBXML2 +import qualified Text.XML.LibXML.Parser as Libxml2 +#endif + +main :: IO () +main = + defaultMain + [ env + (S.readFile "data/books-4kb.xml") + (\input -> + bgroup + "4KB" + [ bench "hexml-dom" (whnf Hexml.parse input) + , bench "xeno-sax" (whnf Xeno.SAX.validate input) + , bench "xeno-dom" (whnf Xeno.DOM.parse input) + , bench + "hexpat-sax" + (whnf + ((Hexpat.parseThrowing Hexpat.defaultParseOptions :: L.ByteString -> [Hexpat.SAXEvent ByteString ByteString]) . + L.fromStrict) + input) + , bench + "hexpat-dom" + (whnf + ((HexpatTree.parse' HexpatTree.defaultParseOptions :: ByteString -> Either HexpatTree.XMLParseError (HexpatTree.Node ByteString ByteString))) + input) + , bench "xml-dom" (nf XML.parseXMLDoc input) +#ifdef LIBXML2 + , bench "libxml2-dom" (whnfIO (Libxml2.parseMemory input)) +#endif + ]) + , env + (S.readFile "data/text-31kb.xml") + (\input -> + bgroup + "31KB" + [ bench "hexml-dom" (whnf Hexml.parse input) + , bench "xeno-sax" (whnf Xeno.SAX.validate input) + , bench "xeno-dom" (whnf Xeno.DOM.parse input) + , bench + "hexpat-sax" + (nf + ((Hexpat.parseThrowing Hexpat.defaultParseOptions :: L.ByteString -> [Hexpat.SAXEvent ByteString ByteString]) . + L.fromStrict) + input) + , bench + "hexpat-dom" + (whnf + ((HexpatTree.parse' HexpatTree.defaultParseOptions :: ByteString -> Either HexpatTree.XMLParseError (HexpatTree.Node ByteString ByteString))) + input) + , bench "xml-dom" (nf XML.parseXMLDoc input) +#ifdef LIBXML2 + , bench "libxml2-dom" (whnfIO (Libxml2.parseMemory input)) + +#endif + ]) + , env + (S.readFile "data/fabricated-211kb.xml") + (\input -> + bgroup + "211KB" + [ bench "hexml-dom" (whnf Hexml.parse input) + , bench "xeno-sax" (whnf Xeno.SAX.validate input) + , bench "xeno-dom" (whnf Xeno.DOM.parse input) + , bench + "hexpat-sax" + (nf + ((Hexpat.parseThrowing Hexpat.defaultParseOptions :: L.ByteString -> [Hexpat.SAXEvent ByteString ByteString]) . + L.fromStrict) + input) + , bench + "hexpat-dom" + (whnf + ((HexpatTree.parse' HexpatTree.defaultParseOptions :: ByteString -> Either HexpatTree.XMLParseError (HexpatTree.Node ByteString ByteString))) + input) + , bench "xml-dom" (nf XML.parseXMLDoc input) +#ifdef LIBXML2 + , bench "libxml2-dom" (whnfIO (Libxml2.parseMemory input)) +#endif + ]) + ] + +deriving instance Generic Content +deriving instance Generic Element +deriving instance Generic CData +deriving instance Generic CDataKind +deriving instance Generic QName +deriving instance Generic Attr +instance NFData Content +instance NFData Element +instance NFData CData +instance NFData CDataKind +instance NFData QName +instance NFData Attr diff --git a/src/Control/Spork.hs b/src/Control/Spork.hs new file mode 100644 --- /dev/null +++ b/src/Control/Spork.hs @@ -0,0 +1,18 @@ +-- | Like the spoon package, but for catching one specific exception +-- type and returning it. + +module Control.Spork + ( spork + ) where + +import Control.Exception +import System.IO.Unsafe + +-- | Evaluate a and return left if it throws an pure exception. +spork + :: Exception e + => a -> Either e a +spork a = + unsafePerformIO $ + (Right `fmap` evaluate a) `catches` [Handler (\e -> pure (Left e))] +{-# INLINEABLE spork #-} diff --git a/src/Xeno/DOM.hs b/src/Xeno/DOM.hs new file mode 100644 --- /dev/null +++ b/src/Xeno/DOM.hs @@ -0,0 +1,207 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | DOM parser and API for XML. + +module Xeno.DOM + ( parse + , Node + , Content(..) + , name + , attributes + , contents + , children + ) where + +import Control.DeepSeq +import Control.Monad.ST +import Control.Spork +import Data.ByteString (ByteString) +import qualified Data.ByteString as S +import Data.ByteString.Internal (ByteString(PS)) +import Data.Mutable +import Data.STRef +import Data.Vector.Unboxed ((!)) +import qualified Data.Vector.Unboxed as UV +import qualified Data.Vector.Unboxed.Mutable as UMV +import Xeno.SAX +import Xeno.Types + +-- | Some XML nodes. +data Node = Node !ByteString !Int !(UV.Vector Int) + deriving (Eq) + +instance NFData Node where + rnf !_ = () + +instance Show Node where + show n = + "(Node " ++ + show (name n) ++ + " " ++ show (attributes n) ++ " " ++ show (contents n) ++ ")" + +-- | Content of a node. +data Content + = Element {-# UNPACK #-}!Node + | Text {-# UNPACK #-}!ByteString + deriving (Show) + +-- | Get just element children of the node (no text). +children :: Node -> [Node] +children (Node str start offsets) = collect firstChild + where + collect i + | i < endBoundary = + case offsets ! i of + 0x00 -> Node str i offsets : collect (offsets ! (i + 4)) + 0x01 -> collect (i + 3) + _ -> [] + | otherwise = [] + firstChild = go (start + 5) + where + go i + | i < endBoundary = + case offsets ! i of + 0x02 -> go (i + 5) + _ -> i + | otherwise = i + endBoundary = offsets ! (start + 4) + +-- | Contents of a node. +contents :: Node -> [Content] +contents (Node str start offsets) = collect firstChild + where + collect i + | i < endBoundary = + case offsets ! i of + 0x00 -> + Element + (Node str i offsets) : + collect (offsets ! (i + 4)) + 0x01 -> + Text (substring str (offsets ! (i + 1)) (offsets ! (i + 2))) : + collect (i + 3) + _ -> [] + | otherwise = [] + firstChild = go (start + 5) + where + go i | i < endBoundary = + case offsets ! i of + 0x02 -> go (i + 5) + _ -> i + | otherwise = i + endBoundary = offsets ! (start + 4) + +-- | Attributes of a node. +attributes :: Node -> [(ByteString,ByteString)] +attributes (Node str start offsets) = collect (start + 5) + where + collect i + | i < endBoundary = + case offsets ! i of + 0x02 -> + ( substring str (offsets ! (i + 1)) (offsets ! (i + 2)) + , substring str (offsets ! (i + 3)) (offsets ! (i + 4))) : + collect (i + 5) + _ -> [] + | otherwise = [] + endBoundary = offsets ! (start + 4) + +-- | Name of the element. +name :: Node -> ByteString +name (Node str start offsets) = + case offsets ! start of + 0x00 -> substring str (offsets ! (start + 2)) (offsets ! (start + 3)) + _ -> mempty + +-- | Parse a complete Nodes document. +parse :: ByteString -> Either XenoException Node +parse str = + case spork node of + Left e -> Left e + Right r -> + case r ! 0 of + 0x00 -> Right (Node str 0 r) + _ -> Left XenoExpectRootNode + where + node = + runST + (do nil <- UMV.new 1000 + vecRef <- newSTRef nil + sizeRef <- fmap asURef (newRef 0) + parentRef <- fmap asURef (newRef 0) + process + (\(PS _ name_start name_len) -> do + let tag = 0x00 + tag_end = -1 + index <- readRef sizeRef + v' <- + do v <- readSTRef vecRef + if index + 5 < UMV.length v + then pure v + else do + v' <- UMV.grow v (UMV.length v) + writeSTRef vecRef v' + return v' + tag_parent <- readRef parentRef + do writeRef parentRef index + writeRef sizeRef (index + 5) + do UMV.write v' index tag + UMV.write v' (index + 1) tag_parent + UMV.write v' (index + 2) name_start + UMV.write v' (index + 3) name_len + UMV.write v' (index + 4) tag_end) + (\(PS _ key_start key_len) (PS _ value_start value_len) -> do + index <- readRef sizeRef + v' <- + do v <- readSTRef vecRef + if index + 5 < UMV.length v + then pure v + else do + v' <- UMV.grow v (UMV.length v) + writeSTRef vecRef v' + return v' + let tag = 0x02 + do writeRef sizeRef (index + 5) + do UMV.write v' index tag + UMV.write v' (index + 1) key_start + UMV.write v' (index + 2) key_len + UMV.write v' (index + 3) value_start + UMV.write v' (index + 4) value_len) + (\_ -> return ()) + (\(PS _ text_start text_len) -> do + let tag = 0x01 + 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) text_start + UMV.write v' (index + 2) text_len) + (\_ -> do + v <- readSTRef vecRef + -- Set the tag_end slot of the parent. + parent <- readRef parentRef + index <- readRef sizeRef + UMV.write v (parent + 4) index + -- Pop the stack and return to the parent element. + previousParent <- UMV.read v (parent + 1) + writeRef parentRef previousParent) + str + wet <- readSTRef vecRef + arr <- UV.unsafeFreeze wet + size <- readRef sizeRef + return (UV.unsafeSlice 0 size arr)) + +-- | Get a substring of the BS. +substring :: ByteString -> Int -> Int -> ByteString +substring s' start len = S.take len (S.drop start s') +{-# INLINE substring #-} diff --git a/src/Xeno/SAX.hs b/src/Xeno/SAX.hs new file mode 100644 --- /dev/null +++ b/src/Xeno/SAX.hs @@ -0,0 +1,293 @@ +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} + +-- | SAX parser and API for XML. + +module Xeno.SAX + ( process + , fold + , validate + , dump + ) where + +import Control.Exception +import Control.Monad.State.Strict +import Control.Spork +import Data.ByteString (ByteString) +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString.Unsafe as SU +import Data.Functor.Identity +import Data.Monoid +import Data.Word +import Xeno.Types + +-------------------------------------------------------------------------------- +-- Helpful interfaces to the parser + +-- | Parse the XML but return no result, process no events. +validate :: ByteString -> Bool +validate s = + case spork + (runIdentity + (process + (\_ -> pure ()) + (\_ _ -> pure ()) + (\_ -> pure ()) + (\_ -> pure ()) + (\_ -> pure ()) + s)) of + Left (_ :: XenoException) -> False + Right _ -> True + +-- | Parse the XML and pretty print it to stdout. +dump :: ByteString -> IO () +dump str = + evalStateT + (process + (\name -> do + level <- get + lift (S8.putStr (S8.replicate level ' ' <> "<" <> name <> ""))) + (\key value -> lift (S8.putStr (" " <> key <> "=\"" <> value <> "\""))) + (\_ -> do + level <- get + let !level' = level + 2 + put level' + lift (S8.putStrLn (">"))) + (\text -> do + level <- get + lift (S8.putStrLn (S8.replicate level ' ' <> S8.pack (show text)))) + (\name -> do + level <- get + let !level' = level - 2 + put level' + lift (S8.putStrLn (S8.replicate level' ' ' <> " name <> ">"))) + str) + (0 :: Int) + +-- | Fold over the XML input. +fold + :: (s -> ByteString -> s) -- ^ Open tag. + -> (s -> ByteString -> ByteString -> s) -- ^ Attribute key/value. + -> (s -> ByteString -> s) -- ^ End of open tag. + -> (s -> ByteString -> s) -- ^ Text. + -> (s -> ByteString -> s) -- ^ Close tag. + -> s + -> ByteString + -> Either XenoException s +fold openF attrF endOpenF textF closeF s str = + spork + (execState + (process + (\name -> modify (\s' -> openF s' name)) + (\key value -> modify (\s' -> attrF s' key value)) + (\name -> modify (\s' -> endOpenF s' name)) + (\text -> modify (\s' -> textF s' text)) + (\name -> modify (\s' -> closeF s' name)) + str) + s) + +-------------------------------------------------------------------------------- +-- Main parsing function + +-- | Process events with callbacks in the XML input. +process + :: Monad m + => (ByteString -> m ()) -- ^ Open tag. + -> (ByteString -> ByteString -> m ()) -- ^ Tag attribute. + -> (ByteString -> m ()) -- ^ End open tag. + -> (ByteString -> m ()) -- ^ Text. + -> (ByteString -> m ()) -- ^ Close tag. + -> ByteString -> m () +process openF attrF endOpenF textF closeF str = findLT 0 + where + findLT index = + case elemIndexFrom openTagChar str index of + Nothing -> unless (S.null text) (textF text) + where text = S.drop index str + Just fromLt -> do + unless (S.null text) (textF text) + checkOpenComment (fromLt + 1) + where text = substring str index fromLt + 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 + where + this = S.drop index str + findCommentEnd index = + case elemIndexFrom commentChar str index of + Nothing -> throw XenoParseError + 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 + findTagName index0 = + let spaceOrCloseTag = parseName str index + in if | s_index str index0 == questionChar -> + case elemIndexFrom closeTagChar str spaceOrCloseTag of + Nothing -> throw XenoParseError + Just fromGt -> do + findLT (fromGt + 1) + | s_index str spaceOrCloseTag == closeTagChar -> + do let tagname = substring str index spaceOrCloseTag + if s_index str index0 == slashChar + then closeF tagname + else do + openF tagname + endOpenF tagname + findLT (spaceOrCloseTag + 1) + | otherwise -> + do let tagname = substring str index spaceOrCloseTag + openF tagname + result <- findAttributes spaceOrCloseTag + endOpenF tagname + case result of + Right closingTag -> findLT (closingTag + 1) + Left closingPair -> do + closeF tagname + findLT (closingPair + 2) + where + index = + if s_index str index0 == slashChar + then index0 + 1 + else index0 + findAttributes index0 = + if s_index str index == slashChar && + s_index str (index + 1) == closeTagChar + then pure (Left index) + else if s_index str index == closeTagChar + then pure (Right index) + else let afterAttrName = parseName str index + in if s_index str afterAttrName == equalChar + then let quoteIndex = afterAttrName + 1 + usedChar = s_index str quoteIndex + in if usedChar == quoteChar || + usedChar == doubleQuoteChar + then case elemIndexFrom + usedChar + str + (quoteIndex + 1) of + Nothing -> + throw XenoParseError + Just endQuoteIndex -> do + attrF + (substring str index afterAttrName) + (substring + str + (quoteIndex + 1) + (endQuoteIndex)) + findAttributes (endQuoteIndex + 1) + else throw XenoParseError + else throw XenoParseError + where + index = skipSpaces str index0 +{-# INLINE process #-} +{-# SPECIALISE process :: + (ByteString -> Identity ()) -> + (ByteString -> 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 utilities + +-- | /O(1)/ 'ByteString' index (subscript) operator, starting from 0. +s_index :: ByteString -> Int -> Word8 +s_index ps n + | n < 0 = throw XenoStringIndexProblem + | n >= S.length ps = throw XenoStringIndexProblem + | otherwise = ps `SU.unsafeIndex` n +{-# INLINE s_index #-} + +-- | A fast space skipping function. +skipSpaces :: ByteString -> Int -> Int +skipSpaces str i = + if isSpaceChar (s_index str i) + then skipSpaces str (i + 1) + else i +{-# INLINE skipSpaces #-} + +-- | Get a substring of a string. +substring :: ByteString -> Int -> Int -> ByteString +substring s start end = S.take (end - start) (S.drop start s) +{-# INLINE substring #-} + +-- | Basically @findIndex (not . isNameChar)@, but doesn't allocate. +parseName :: ByteString -> Int -> Int +parseName str index = + if not (isNameChar (s_index str index)) + then index + else parseName str (index + 1) +{-# INLINE parseName #-} + +-- | Get index of an element starting from offset. +elemIndexFrom :: Word8 -> ByteString -> Int -> Maybe Int +elemIndexFrom c str offset = fmap (+ offset) (S.elemIndex c (S.drop offset str)) +-- Without the INLINE below, the whole function is twice as slow and +-- has linear allocation. See git commit with this comment for +-- results. +{-# INLINE elemIndexFrom #-} + +-------------------------------------------------------------------------------- +-- Character types + +isSpaceChar :: Word8 -> Bool +isSpaceChar c = c == 32 || (c <= 10 && c >= 9) || c == 13 +{-# INLINE isSpaceChar #-} + +-- | 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 +{-# INLINE isNameChar #-} + +-- | Char for '\''. +quoteChar :: Word8 +quoteChar = 39 + +-- | Char for '"'. +doubleQuoteChar :: Word8 +doubleQuoteChar = 34 + +-- | Char for '='. +equalChar :: Word8 +equalChar = 61 + +-- | Char for '?'. +questionChar :: Word8 +questionChar = 63 + +-- | Char for '/'. +slashChar :: Word8 +slashChar = 47 + +-- | Exclaimation character !. +bangChar :: Word8 +bangChar = 33 + +-- | Open tag character. +commentChar :: Word8 +commentChar = 45 -- '-' + +-- | Open tag character. +openTagChar :: Word8 +openTagChar = 60 -- '<' + +-- | Close tag character. +closeTagChar :: Word8 +closeTagChar = 62 -- '>' diff --git a/src/Xeno/Types.hs b/src/Xeno/Types.hs new file mode 100644 --- /dev/null +++ b/src/Xeno/Types.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} + +-- | Shared types. + +module Xeno.Types where + +import Control.DeepSeq +import Control.Exception +import Data.Typeable +import GHC.Generics + +data XenoException + = XenoStringIndexProblem + | XenoParseError + | XenoExpectRootNode + deriving (Show, Typeable, NFData, Generic) +instance Exception XenoException where displayException = show diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Simple test suite. + +module Main where + +import Data.ByteString (ByteString) +import Test.Hspec +import Xeno.SAX +import Xeno.DOM +import Xeno.Types +-- import Control.Monad.Catch + +import Data.Either + +-- main = print "hello!" + +main :: IO () +main = hspec spec + +spec :: SpecWith () +spec = + describe + "hexml tests" + (do mapM_ + (\(v, i) -> it (show i) (shouldBe (Xeno.SAX.validate i) v)) + hexml_examples_sax + let doc = + parse + "\n" + it + "children test" + (shouldBe + (map name (children $ fromRightE doc)) + ["test", "test", "b", "test", "test"]) + it + "attributes" + (shouldBe + (attributes (head (children $ fromRightE doc))) + [("id", "1"), ("extra", "2")])) + +hexml_examples_sax :: [(Bool, ByteString)] +hexml_examples_sax = + [(True, "herethere") + ,(True, "") + ,(True, "") + ,(True, "here more text at the end") + ,(True, "") -- SAX doesn't care about tag balancing + ,(False, "\nHello, world!") + ] + + +-- | Horrible hack. Don't try this at home. +fromRightE :: Either XenoException a -> a +fromRightE = either (error. show) id diff --git a/xeno.cabal b/xeno.cabal new file mode 100644 --- /dev/null +++ b/xeno.cabal @@ -0,0 +1,61 @@ +name: xeno +version: 0.1 +synopsis: A fast event-based XML parser in pure Haskell +build-type: Simple +category: XML, Parser +cabal-version: >=1.10 +homepage: https://github.com/ocramz/xeno +license: BSD3 +license-file: LICENSE +author: Christopher Done +maintainer: Marco Zocca (zocca.marco gmail) +tested-with: GHC == 8.0.1 +extra-source-files: README.md + CHANGELOG.markdown + +source-repository head + type: git + location: https://github.com/ocramz/xeno + +flag libxml2 + description: Include libxml2 in the benchmarks + default: False + +library + hs-source-dirs: src + ghc-options: -Wall -O2 + exposed-modules: Xeno.SAX, Xeno.DOM, Xeno.Types + other-modules: Control.Spork + build-depends: base >= 4.7 && < 5 + , bytestring, vector, deepseq, array, mutable-containers, mtl + -- , exceptions + -- , hspec + default-language: Haskell2010 + +test-suite xeno-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: base, xeno, hexml, hspec, bytestring + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +benchmark xeno-speed-bench + type: exitcode-stdio-1.0 + hs-source-dirs: bench + main-is: Speed.hs + build-depends: base, xeno, hexml, criterion, bytestring, deepseq, ghc-prim, xml, hexpat + if flag(libxml2) + build-depends: libxml + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -O2 + if flag(libxml2) + ghc-options: -DLIBXML2 + default-language: Haskell2010 + +benchmark xeno-memory-bench + type: exitcode-stdio-1.0 + hs-source-dirs: bench + main-is: Memory.hs + build-depends: base, xeno, weigh, bytestring, deepseq, hexml + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -O2 + default-language: Haskell2010