packages feed

xeno (empty) → 0.1

raw patch · 12 files changed

+1022/−0 lines, 12 filesdep +arraydep +basedep +bytestringsetup-changed

Dependencies added: array, base, bytestring, criterion, deepseq, ghc-prim, hexml, hexpat, hspec, libxml, mtl, mutable-containers, vector, weigh, xeno, xml

Files

+ CHANGELOG.markdown view
@@ -0,0 +1,2 @@+0.1+First Hackage release
+ LICENSE view
@@ -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.
+ README.md view
@@ -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 "<p key='val' x=\"foo\" k=\"\"><a><hr/>hi</a><b>sup</b>hi</p>"+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 = "Text<tag prop='value'>Hello, World!</tag><x><y prop=\"x\">Content!</y></x>Trailing."+> dump input+"Text"+<tag prop="value">+  "Hello, World!"+</tag>+<x>+  <y prop="x">+    "Content!"+  </y>+</x>+"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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bench/Memory.hs view
@@ -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 !_ = ()
+ bench/Speed.hs view
@@ -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
+ src/Control/Spork.hs view
@@ -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 #-}
+ src/Xeno/DOM.hs view
@@ -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 #-}
+ src/Xeno/SAX.hs view
@@ -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 -- '>'
+ src/Xeno/Types.hs view
@@ -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
+ test/Main.hs view
@@ -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+                "<root><test id=\"1\" extra=\"2\" />\n<test id=\"2\" /><b><test id=\"3\" /></b><test id=\"4\" /><test /></root>"+        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, "<test id='bob'>here<extra/>there</test>")+    ,(True, "<test /><close />")+    ,(True, "<test /><!-- comment > --><close />")+    ,(True, "<test id=\"bob value\" another-attr=\"test with <\">here </test> more text at the end<close />")+    ,(True, "<test></more>") -- SAX doesn't care about tag balancing+    ,(False, "<test")+    ,(True, "<?xml version=\"1.1\"?>\n<greeting>Hello, world!</greeting>")+    ]+++-- | Horrible hack. Don't try this at home.+fromRightE :: Either XenoException a -> a+fromRightE = either (error. show) id
+ xeno.cabal view
@@ -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