packages feed

tinyXml (empty) → 0.1.0.0

raw patch · 15 files changed

+1461/−0 lines, 15 filesdep +basedep +bytestringdep +containerssetup-changedbinary-added

Dependencies added: base, bytestring, containers, directory, filepath, hexml, mtl, optparse-generic, primitive, process, tinyXml, vector

Files

+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for bytestring-xml++## 0.1.0.0  -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2016, Pepe Iborra++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 Pepe Iborra nor the names of other+      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 THE COPYRIGHT+OWNER OR CONTRIBUTORS BE 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Test.hs view
@@ -0,0 +1,179 @@++{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE OverloadedStrings, DisambiguateRecordFields #-}++import qualified Text.XML.Hexml as Hexml+import Control.Monad+import Data.Char+import Data.Foldable+import Data.List (sort)+import Data.Monoid+import qualified Data.ByteString.Char8 as BS+import qualified Data.Vector.Storable as V+import System.Process (callCommand)+import System.FilePath+import Text.Printf++import Config+import Text.Xml.Tiny+import Text.Xml.Tiny.Internal(Node(..), Attribute(..), ParseDetails(ParseDetails), AttributeParseDetails(..), Slice)+import qualified Text.Xml.Tiny.Internal as Slice++examples :: [(Bool, BS.ByteString)]+examples =+    [(True,"<hello>world</hello>")+    ,(True,"<hello/>")+    ,(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 />")+    ,(False, "<test></more>")+    ,(False, "<test")+    ,(True, "<?xml version=\"1.1\"?>\n<greeting>Hello, world!</greeting>")+    ]++xmlFiles = [ "mail", "benchmark" ]++main = do+    forM_ examples $ \(parses,src) -> do+         case parse src of+            Left err ->+              when parses $ fail ("Unexpected failure on " ++ BS.unpack src ++ ": " ++ show err)+            Right doc -> do+              unless parses $ fail ( "Unexpected success on " ++ BS.unpack src)+              print src+              print doc++    let Right doc = parse "<test id=\"1\" extra=\"2\" />\n<test id=\"2\" /><b><test id=\"3\" /></b><test id=\"4\" /><test />"+    map name (children doc) === ["test","test","b","test","test"]+    location (children doc !! 2) === (2,16)+    length (childrenBy doc "test") === 4+    length (childrenBy doc "b") === 1+    length (childrenBy doc "extra") === 0+    attributes (head $ children doc) === [Attribute "id" "1", Attribute "extra" "2"]+    map (`attributeBy` "id") (childrenBy doc "test") === map (fmap (Attribute "id")) [Just "1", Just "2", Just "4", Nothing]++    Right _ <- return $ parse $ "<test " <> BS.unwords [BS.pack $ "x" ++ show i ++ "='value'" | i <- [1..10000]] <> " />"+    Right _ <- return $ parse $ BS.unlines $ replicate 10000 "<test x='value' />"++    let attrs = ["usd:jpy","test","extra","more","stuff","jpy:usd","xxx","xxxx"]+    Right doc <- return $ parse $ "<test " <> BS.unwords [x <> "='" <> x <> "'" | x <- attrs] <> ">middle</test>"+    [c] <- return $ childrenBy doc "test"++    forM_ attrs $ \a -> attributeBy c a === Just (Attribute a a)+    forM_ ["missing","gone","nothing"] $ \a -> attributeBy c a === Nothing++    forM_ xmlFiles $ \name -> do+      putStrLn ""++      let path   = "xml" </> name <.> "xml"+      let pathGz = path <.> ".bz2"+      callCommand $ "bunzip2 -f -k " ++ pathGz+      xml <- BS.readFile path+      let us = either (error $ "failed to parse: " ++ path) id $ parse xml++      checkStructure us++      let hexml = either (error $ "Hexml failed to parse: " ++ path ) id $ Hexml.parse xml+      testEq us hexml++    putStrLn "\nSuccess"++checkFind :: Node -> IO ()+checkFind n = do+    forM_ (attributes n) $ \a -> attributeBy n (attributeName a) === Just a+    attributeBy n "xxx" === (Nothing :: Maybe Attribute)+    let cs = children n+    forM_ ("xxx":map name cs) $ \c ->+        map outer (filter ((==) c . name) cs) === map outer (childrenBy n c)+    mapM_ checkFind $ children n++pairs f (a:b:rest) = f a b && pairs f (b:rest)+pairs f _ = True++checkStructure :: Config => Node -> IO ()+checkStructure n = checkNode [] n where+  checkNode path n@Node{attributesV, slices=ParseDetails{attributes}} = do+    let nn = children n+    unless (sorted nn) $ fail "not sorted"+    unless (pairs (nonOverlapping path) nn) $ fail "overlapping children nodes"+    unless (pairs nonOverlappingA (Slice.vector attributes attributesV)) $ fail "overlapping attributes"+    putChar '.'+    forM_ nn $ \n' -> checkNode (name n : path) n'++  nonOverlapping :: Config => [BS.ByteString] -> Node -> Node -> Bool+  nonOverlapping path n1@Node{slices=ParseDetails{outer=o1}} n2@Node{slices=ParseDetails{outer=o2}} =+    nonOverlappingS o1 o2+    || error (printf "%s Overlapping nodes: %s(%s) %s(%s)" (show path) (show$ outer n1) (show $ location n1) (show$ outer n2) (show$ location n2))++  nonOverlappingA :: Config => AttributeParseDetails -> AttributeParseDetails -> Bool+  nonOverlappingA a1@(AttributeParseDetails n v) a2@(AttributeParseDetails n' v') =+    let slices = [n,v,n',v']+    in  and [ s >= s' || nonOverlappingS s s'+              | s <- slices, s' <- slices]+        || error (printf "overlapping attributes" (show a1) (show a2))++  nonOverlappingS :: Config => Slice -> Slice -> Bool+  nonOverlappingS s1 s2 =    Slice.end s1 <= Slice.start s2+                          || Slice.end s2 <= Slice.start s1+                          -- || error (printf "Overlapping slices: %s, %s" (show s1) (show s2))++  sorted nn =+    let outers = map (Slice.start.Slice.outer.slices) nn+    in sort outers == outers+    || error ("Internal error - nodes not sorted: " +++              show [ (name n, Slice.start(Slice.outer(slices n))) | n <- nn])++class (Show a, Show b) => TestEq a b where testEq :: a -> b -> IO ()++(===) :: Config => TestEq a a => a -> a -> IO ()+(===) = testEq++instance (Show a, Eq a) => TestEq a a where+  a `testEq` b = if a == b then putChar '.' else error $ "mismatch, " ++ show a ++ " /= " ++ show b++instance TestEq Node Hexml.Node where+  testEq n n' = do+    name n `testEq` Hexml.name n'+    test "attributes" (attributes n) (Hexml.attributes n')+    test "contents"   (contents n)   (Hexml.contents n')++   where+     test (msg :: String) aa bb+       | length aa == length bb = zipWithM_ testEq aa bb+       | otherwise = error$ printf "Length of %s does not match (%d /= %d):\n%s\n---------------\n%s" msg (length aa) (length bb) (show aa) (show bb)++instance TestEq Attribute Hexml.Attribute where+    Attribute n v `testEq` Hexml.Attribute n' v' = do+      n `testEq` n'+      v `testEq` v'++instance (Show a, Show b, TestEq a a', TestEq b b') => TestEq (Either a b) (Either a' b') where+  Left  e `testEq` Left e'  = e `testEq` e'+  Right x `testEq` Right x' = x `testEq` x'+  testEq a b = error $ printf "mismatch in children: %s /= %s" (show a) (show b)++debugShow :: Node -> String+debugShow n =+    unlines $+         "Nodes buffer: "+       : [ "  " ++ show n | n <- V.toList $ nodesV n]+       ++ showNodeContents (Right n)+     where+       showNodeContents :: Either BS.ByteString Node -> [String]+       showNodeContents (Right n) =+          [ "Node contents:"+          , "  name: " ++ show (name n)+          , "  slices: " ++ show (slices n)+          , "  attributes: " ++ (show $ attributes n)+          , "  contents: "+          ] +++          [ "    " ++ l | n' <- contents n, l <- showNodeContents n']+       showNodeContents (Left txt) =+          [ "Text content: " ++ BS.unpack txt ]
+ Validate.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE DeriveAnyClass    #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators     #-}++import Text.Xml.Tiny+import Control.Monad+import qualified Data.ByteString.Char8 as BS++import Options.Generic+import System.Directory+import System.FilePath+import System.IO+import System.Environment++import Text.Printf++data Options =+  Options { reprint :: Bool <?> "Reprint the XML document" }+  deriving (Generic, Show, ParseRecord)++data Args = Args Options [String] deriving (Generic, Show)++instance ParseRecord Args where parseRecord = Args <$> parseRecord <*> parseRecord++main = do+  Args args paths <- getRecord "Validate XML"+  hSetBuffering stdout LineBuffering+  forM_ paths $ \p -> do+    contents <- BS.readFile p+    case parse contents of+      Left e -> print e+      Right node -> do+        putStrLn "OK"+        when (unHelpful $ reprint args) $ do+          let destPath = p <.> "reprint"+          existsAlready <- doesFileExist destPath+          if existsAlready+            then putStrLn $ "Overwriting " ++ destPath+            else putStrLn $ "Reprinting to " ++ destPath+          BS.writeFile destPath (rerender node)
+ src/Config.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE ConstraintKinds, KindSignatures, ImplicitParams, CPP #-}+module Config where++import GHC.Exts+import qualified GHC.Stack+import qualified Debug.Trace++trace :: String -> a -> a+#ifdef TRACE+trace msg = Debug.Trace.trace msg+#else+trace msg x = x+#endif+{-# INLINE trace #-}++#if __GLASGOW_HASKELL__ < 800+type HasCallStack = (?callStack :: GHC.Stack.CallStack)+#else+type HasCallStack = GHC.Stack.HasCallStack+#endif++#ifdef STACKTRACES+type Config = HasCallStack+#else+type Config = (() :: Constraint)+#endif+
+ src/Data/VectorBuilder/Storable.hs view
@@ -0,0 +1,174 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE CPP #-}+module Data.VectorBuilder.Storable+  (VectorBuilder, new, indexFromEnd, insert, push, pop, updateStackElt, getCount, getStackCount, finalize, unsafeToMVector, peek+  ) where++import Control.Exception (assert)+import Control.Monad+import Control.Monad.ST.Unsafe+import Control.Monad.Primitive+import Data.Int+import Data.Primitive.MutVar+import qualified Data.Vector.Storable as S+import qualified Data.Vector.Storable.Mutable as SM+import qualified Data.Vector.Generic.Mutable as M+--import qualified Data.Vector.Storable.Mutable as M+import qualified Data.Vector.Unboxed.Mutable  as U+import Foreign (Storable(sizeOf), Ptr, plusPtr)+import Foreign.ForeignPtr+import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)+import Config+import Text.Printf++default (Int, Double)++data VectorBuilder s a =+  VectorBuilder+    {+      -- We use an unboxed vector instead of a MutVar, which would have to be boxed+      --  (writing to MutVar is slow because of GC book keeping)+      next  :: {-# UNPACK #-} !(U.MVector s Int32)  -- ^ The next free index in the mutable store+      -- The MVector is in a MutVar because grow is not in-place+    , store :: {-# UNPACK #-} !(MutVar s (S.MVector s a))    -- ^ The mutable store+    }++readU  :: (Config, _) => _+writeU :: (Config, _) => _+writeM :: (Config, _) => _+readM :: (Config, _) => _+copyM :: (Config, _) => _+sliceM :: (Config, _) => _+getCount, getStackCount :: Config => PrimMonad m => VectorBuilder(PrimState m) a -> m Int32++#ifdef ENABLE_VECTOR_CHECKS+readU  a = U.read  a+writeU a = U.write a+writeM a ix = M.write a (fromIntegral ix)+readM  a ix = M.read a  (fromIntegral ix)+copyM  a = M.copy a+sliceM a b = M.slice (fromIntegral a) (fromIntegral b)+#else+readU  a = U.unsafeRead  a+writeU a = U.unsafeWrite a+writeM a !ix = M.unsafeWrite a (fromIntegral ix)+readM  a !ix = M.unsafeRead a (fromIntegral ix)+copyM  a = M.unsafeCopy a+sliceM a b = M.unsafeSlice (fromIntegral a) (fromIntegral b)+#endif++-- | Yields the number of elements stored in the buffer+getCount l = readU (next l) 0++-- | Yields the number of elements in the stack+getStackCount l = readU  (next l) 1++-- | Ensure that there is sufficient space+request :: (Config, Storable a, PrimMonad m) => Int32 -> VectorBuilder (PrimState m) a -> m ()+request !n VectorBuilder{next,store} = do+  frontCount <- readU  (next) 0+  backCount  <- readU  (next) 1+  assert (frontCount >= 0) $ return ()+  assert (backCount >= 0) $ return ()+  a <- readMutVar (store)+  let !len = M.length a+  unless (frontCount + backCount + n < fromIntegral len) $ do+        return ()+        a' <- newVectorAllocatedExternally(len*2)+        copyM (sliceM 0 frontCount a') (sliceM 0 frontCount a)+        copyM (sliceM (2 * fromIntegral len - backCount) backCount a') (sliceM (fromIntegral len - backCount) backCount a)+        writeMutVar (store ) a'+{-# INLINE request #-}++-- | Inserts an element at the next free position in the vector and returns the index+insert :: (Config, PrimMonad m, Storable a) => VectorBuilder (PrimState m) a -> a -> m ()+insert l@VectorBuilder{next,store} v = do+  request 1 l+  nextI <- readU  (next ) 0+  writeU (next ) 0 (nextI + 1)+  a <- readMutVar (store )+  writeM a nextI v+{-# INLINE insert #-}++-- | Push an element into a stack-like temporary storage. Returns the index from the back+push :: (Config, PrimMonad m, Storable a) => VectorBuilder (PrimState m) a -> a -> m Int32+push l@VectorBuilder{next,store} !v = do+  request 1 l+  stackCount <- readU  (next) 1+  writeU (next) 1 (stackCount + 1)+  assert (stackCount >= 0) $ return ()+  a <- readMutVar (store)+  let ix = (fromIntegral $ M.length a) - stackCount - 1+  writeM a ix v+  return stackCount+{-# INLINE push #-}++-- | Peek into the temporary stack+peek :: Config => (Storable a, PrimMonad m, Storable a, Num n, Integral n, Ord n) => VectorBuilder (PrimState m) a -> n -> m a+peek VectorBuilder{next, store} n = do+  backCount <- readU next 1+  assert(fromIntegral backCount > n) $ return ()+  a <- readMutVar store+  readM a (M.length a - fromIntegral backCount - 1 + fromIntegral n)++updateStackElt :: Config => (Storable a, PrimMonad m, Storable a) => VectorBuilder (PrimState m) a -> Int32 -> (a -> a) -> m ()+updateStackElt VectorBuilder{store} i f = do+  arr <- readMutVar store+  let ix = (M.length arr - fromIntegral i - 1)+  a <- readM arr ix+  writeM arr ix (f a)+{-# INLINE updateStackElt #-}++indexFromEnd :: forall a m . Config => (Storable a, PrimMonad m, Storable a) => VectorBuilder (PrimState m) a -> Int32 -> m (Ptr a)+indexFromEnd VectorBuilder{store} i = do+  a <- readMutVar store+  let (fptr, _) = SM.unsafeToForeignPtr0 a+  let ptr = unsafeForeignPtrToPtr fptr+  let s = sizeOf(undefined :: a)+  return $ plusPtr ptr ((M.length a - fromIntegral i -  1) * s)++-- | Yield a short lived reference to the underlying foreign vector.+--   Note that Insert and Push may allocate a new underlying vector.+unsafeToMVector l = readMutVar (store l)++-- | Pop elements out of the temporary stack and append into the main buffer+pop :: Config => (Storable a, PrimMonad m, Storable a) => VectorBuilder (PrimState m) a -> Int32 -> m ()+pop l@VectorBuilder{next, store} n = do+  request n l+  backCount <- readU next 1+  frontCount <- readU next 0+  assert(backCount >= n) $ return ()+  writeU next 0 (frontCount +  n)+  writeU next 1 (backCount - n)+  a <- readMutVar store+  let !l = M.length a+  let !first = fromIntegral l - backCount+  forM_ [1..n] $ \i ->+    let from = frontCount - 1 + i+        to   = first+n-i+    in when (from /= to) $+        copyM (sliceM from 1 a) (sliceM to 1 a)+{-# INLINE pop #-}++-- | Extracts an immutable vector. The VectorBuilder can no longer be used after this+finalize :: (Config, PrimMonad m, Storable a) => VectorBuilder (PrimState m) a -> m (S.Vector a)+finalize l = trace "VectorBuilder.finalize" $ do+  v <- readMutVar (store l)+  frontCount <- readU (next l) 0+  S.unsafeFreeze (sliceM 0 frontCount v)++new :: (Config, PrimMonad m, Storable a) => Int -> m (VectorBuilder (PrimState m) a)+new initialSize = do+  next <- U.unsafeNew 2+  writeU next 0 0+  writeU next 1 0+  store <- newVectorAllocatedExternally initialSize+  storeRef <- newMutVar store+  return (VectorBuilder next storeRef)++newVectorAllocatedExternally size = (`SM.unsafeFromForeignPtr0` size) <$> primToPrim (unsafeIOToST $ mallocForeignPtrArray size)
+ src/Text/Xml/Tiny.hs view
@@ -0,0 +1,124 @@+{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-name-shadowing #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DisambiguateRecordFields #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NamedFieldPuns #-}++-- | This module contains functions for parsing an XML document and deconstructing the AST.+module Text.Xml.Tiny+  ( Node, name, inner, outer, contents, location+  , Attribute(..)+  , parse+  , children, childrenBy+  , attributes, attributeBy+  , SrcLoc(..)+  , Error(..)+  , ErrorType(..)+  , rerender+  ) where++import Control.Exception+import Text.Xml.Tiny.Internal (Node(..), Attribute(..), ParseDetails(ParseDetails), AttributeParseDetails(..), Error(..), ErrorType(..), SrcLoc(..))+import qualified Text.Xml.Tiny.Internal as Slice+import qualified Text.Xml.Tiny.Internal.Parser as Internal+import Data.ByteString.Internal (ByteString(..))+import qualified Data.ByteString.Char8 as BS+import Data.Char+import Data.Int+import Data.Maybe (listToMaybe)+import Data.Monoid+import Config+import Text.Printf++-- | Parse an XML bytestring, returning a root node with name "" and the content AST, or an error.+--   Note that the returned AST references the input bytestring and will therefore keep it alive.+parse :: Config => ByteString -> Either Error Node+parse bs =+  case Internal.parse bs of+    Left e -> Left e+    Right (attV, nV, slices) -> Right $ Node attV nV bs slices++instance Show Node where+  -- | Returns a simplified rendering of the node.+  --   If you want a full rendering, use `outer`+  show n =+    case children n of+      [] -> printf "<%s%s/>" nameN attrs+      _  -> printf "<%s%s>...</%s>" nameN attrs nameN+   where+    nameN = BS.unpack $ name n+    attrs = unwords [ BS.unpack n <> "=" <> BS.unpack v | Attribute n v <- attributes n]++name, inner, outer :: Config => Node -> ByteString+-- | The tag name+name  Node{source, slices = ParseDetails{..}} = Slice.render name source+-- | The content of the tag, excluding the tag itself+inner Node{source, slices = ParseDetails{..}} = Slice.render inner source+-- | The contents of the tag, including the tag itself+outer Node{source, slices = ParseDetails{..}} = Slice.render outer source+-- | The attributes in the tag, if any.+attributes :: Config => Node -> [Attribute]+attributes Node{attributesV, source, slices = ParseDetails{attributes}} =+  [ Attribute (Slice.render n source) (Slice.render v source)+    | AttributeParseDetails n v <- Slice.vector attributes attributesV ]++-- | Get the slices of a node, including both the content strings (as 'Left', never blank) and+--   the direct child nodes (as 'Right').+--   If you only want the child nodes, use 'children'.+contents :: Config => Node -> [Either BS.ByteString Node]+contents n@Node{source, slices=ParseDetails{inner}} =+     f (Slice.start inner) (children n)+    where+        f :: Config => Int32 -> [Node] -> [Either BS.ByteString Node]+        f i [] = string i (Slice.end inner) ++ []+        f i (n@Node{slices=ParseDetails{outer}} : nn) = string i (Slice.start outer) ++ Right n+                                                       : f (Slice.end outer) nn+        string :: Config => Int32 -> Int32 -> [Either BS.ByteString Node]+        string start end+          | assert (start<=end || error (printf "start=%d, end=%d" start end)) False = undefined+          | start == end = []+          | otherwise = [Left $ Slice.render (Slice.fromOpenClose start end) source]++-- | Get the direct child nodes of this node.+children :: Node -> [Node]+children Node{slices = ParseDetails{nodeContents}, ..} =+  [ Node{..} | slices <- Slice.vector nodeContents nodesV ]++-- | Get the direct children of this node which have a specific name.+childrenBy :: Config => Node -> BS.ByteString -> [Node]+childrenBy node str =+  filter (\n -> name n == str) (children node)++-- | Get the first attribute of this node which has a specific name, if there is one.+attributeBy :: Config => Node -> BS.ByteString -> Maybe Attribute+attributeBy node str = listToMaybe [ a | a@(Attribute name _) <- attributes node, name == str ]++-- | Get the (line, col) coordinates of a node+location :: Config => Node -> (Int, Int)+location Node{source, slices=ParseDetails{outer}} =+  BS.foldl' f (pair 1 1) $ BS.take (fromIntegral $ Slice.start outer) source+    where+        pair !a !b = (a,b)+        f (!line, !col) c+            | c == '\n' = pair (line+1) 1+            | c == '\t' = pair line (col+8)+            | otherwise = pair line (col+1)++-- | Returns the XML bytestring reconstructed from the parsed AST.+--   For the original XML, use `outer`+rerender :: Node -> BS.ByteString+rerender = inside+    where+        inside x = BS.concat $ map (either validStr node) $ contents x+        node x = "<" <> BS.unwords (validName (name x) : map attr (attributes x)) <> ">" <>+                 inside x <>+                 "</" <> name x <> ">"+        attr (Attribute a b) = validName a <> "=\"" <> validAttr b <> "\""++        validName x | BS.all (\x -> isAlphaNum x || x `elem` ("-:_" :: String)) x = x+                    | otherwise = error "Invalid name"+        validAttr x | BS.notElem '\"' x = x+                    | otherwise = error "Invalid attribute"+        validStr x | BS.notElem '<' x || BS.isInfixOf "<!--" x = x+                   | otherwise = error $ show ("Invalid string", x)
+ src/Text/Xml/Tiny/Internal.hs view
@@ -0,0 +1,208 @@+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DisambiguateRecordFields, NamedFieldPuns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE CPP #-}++-- | This module contains types and functions that are mostly+--   intended for the test suite, and should be considered internal+--   for all other purposes+module Text.Xml.Tiny.Internal+  (+-- * XML Nodes+    Node(..), Attribute(..)+-- * ParseDetails+  , ParseDetails(..), AttributeParseDetails(..)+-- * Slices+  , Slice(..)+  , fromOpen, fromOpenClose, fromIndexPtr+  , empty+  , start, end+  , take, drop, null+  , vector, render, toList+-- * Errors+  , SrcLoc(..), Error(..), ErrorType(..)+  ) where++import Control.Exception+import Data.ByteString.Char8 (ByteString)+import Data.ByteString.Internal (ByteString(..))+import Data.List (genericTake)+import Data.Vector.Storable (Vector, (!))+import qualified Data.Vector.Storable as V+import Data.Word+import GHC.Stack hiding (SrcLoc)+import Foreign.ForeignPtr       (ForeignPtr)+import Foreign+import Prelude hiding (length, null, take, drop)++import Text.Printf++import Config+++-- A subset of a vector defined by an offset and length+data Slice =+  Slice { offset, length :: !Int32 }+  deriving (Eq,Ord,Show)++sInt :: Int+sInt = sizeOf(0::Int32)++instance Storable Slice where+    sizeOf _ = sInt * 2+    alignment _ = alignment (0 :: Int64)+    peek p = Slice <$> peekByteOff p 0 <*> peekByteOff p sInt+    poke p Slice{..} = pokeByteOff p 0 offset >> pokeByteOff p sInt length++{-# INLINE empty #-}+empty :: Slice+empty = Slice 0 0++fromOpen:: Config => Integral a => a -> Slice+fromOpen o = Slice (fromIntegral o) 0++{-# INLINE fromOpenClose #-}+fromOpenClose :: Config => (Integral a1, Integral a) => a -> a1 -> Slice+fromOpenClose (fromIntegral->open) (fromIntegral->close) = Slice open (close-open)++{-# INLINE null #-}+null :: Config => Slice -> Bool+null (Slice _ l) = l == 0++{-# INLINE take #-}+take :: Config => Integral a => a -> Slice -> Slice+take !(fromIntegral -> i) (Slice o l) = assert (l>=i) $ Slice o i++{-# INLINE drop #-}+drop :: Config => Integral t => t -> Slice -> Slice+drop !(fromIntegral -> i) (Slice o l) = assert (l>=i || error(printf "drop %d (Slice %d %d)" i o l)) $ Slice (o+i) (l-i) ++-- | Inclusive+start :: Config => Slice -> Int32+start = offset++-- | Non inclusive+end :: Config => Slice -> Int32+end (Slice o l) = o + l++-- | Returns a list of indexes+toList :: Config => Slice -> [Int]+toList (Slice o l) = genericTake l [ fromIntegral o ..]++{-# INLINE fromIndexPtr #-}+-- | Apply a slice to a foreign ptr of word characters and wrap as a bytestring+fromIndexPtr :: Config => Slice -> ForeignPtr Word8 -> ByteString+fromIndexPtr (Slice o l) fptr = PS fptr (fromIntegral o) (fromIntegral l)++-- | Apply a slice to a bytestring+render :: Config => Slice -> ByteString -> ByteString+render(Slice o l) _ | trace (printf "Render slice %d %d" o l) False = undefined+render(Slice o l) _ | assert (o >= 0 && l >= 0) False = undefined+render(Slice o l) (PS fptr _ _) = PS fptr (fromIntegral o) (fromIntegral l)++-- | Apply a slice to a vector+vector :: Config => Storable a => Slice -> Vector a -> [a]+vector s v = [ v ! i+              | i <- toList s+              , assert (i < V.length v) True ]++-- * XML Nodes++-- | A parsed XML node+data Node =+  Node{ attributesV :: !(Vector AttributeParseDetails) -- ^ All the attributes in the document+      , nodesV      :: !(Vector ParseDetails)          -- ^ All the nodes in the document+      , source      :: !ByteString                     -- ^ The document bytes+      , slices      :: !ParseDetails                   -- ^ Details for this node+      }++-- | A parsed XML attribute+data Attribute = Attribute { attributeName, attributeValue :: !ByteString } deriving (Eq, Show)++data ParseDetails =+    ParseDetails+    { name :: {-# UNPACK #-} !Slice     -- ^ bytestring slice+    , inner :: {-# UNPACK #-} !Slice    -- ^ bytestring slice+    , outer :: {-# UNPACK #-} !Slice    -- ^ bytestring slice+    , attributes :: {-# UNPACK #-} !Slice   -- ^ ParseDetailsAttribute slice+    , nodeContents :: {-# UNPACK #-} !Slice -- ^ ParseDetails slice of children+    }+    -- | An incompletely defined set of parse details+  | ProtoParseDetails { name, attributes :: !Slice, innerStart, outerStart :: !Int32 }+  deriving (Show)++-- | Assumes that a name can never be the empty slice+instance Storable ParseDetails where+  sizeOf    _ = sizeOf empty * 5+  alignment _ = alignment(0::Int)+  poke !q (ParseDetails a b c d e)  = let p = castPtr q in pokeElemOff p 0 a >> pokeElemOff p 1 b >> pokeElemOff p 2 c >> pokeElemOff p 3 d >> pokeElemOff p 4 e+  poke !q (ProtoParseDetails (Slice no nl) (Slice ao al) i o) = do+    let !p = castPtr q+    pokeElemOff p 0 no+    pokeElemOff p 1 (0::Int32)+    pokeElemOff p 2 nl+    pokeElemOff p 3 ao+    pokeElemOff p 4 al+    pokeElemOff p 5 i+    pokeElemOff p 6 o+  peek q = do+    let !p = castPtr q+    !header <- peekElemOff p 1+    if header == (0::Int32)+      then protoNode <$> peekElemOff p 0 <*> peekElemOff p 2 <*> peekElemOff p 3 <*> peekElemOff p 4 <*> peekElemOff p 5 <*> peekElemOff p 6+      else let !p = castPtr q in ParseDetails <$> peekElemOff p 0 <*> peekElemOff p 1 <*> peekElemOff p 2 <*> peekElemOff p 3 <*> peekElemOff p 4+     where+       protoNode no nl ao al = ProtoParseDetails (Slice no nl) (Slice ao al)++data AttributeParseDetails =+  AttributeParseDetails+  { nameA :: {-# UNPACK #-} !Slice,+    value :: {-# UNPACK #-} !Slice+  }+  deriving (Eq, Show)++instance Storable AttributeParseDetails where+  sizeOf _ = sizeOf empty * 2+  alignment _ = alignment (0 :: Int)+  peek !q = do+    let !p = castPtr q :: Ptr Slice+    !a <- peekElemOff p 0+    !b <- peekElemOff p 1+    return (AttributeParseDetails a b)+  poke !q (AttributeParseDetails a b)= do+    let !p = castPtr q :: Ptr Slice+    pokeElemOff p 0 a+    pokeElemOff p 1 b++-- * Error types++newtype SrcLoc = SrcLoc Int deriving Show++data Error = Error ErrorType CallStack+data ErrorType =+    UnterminatedComment SrcLoc+  | UnterminatedTag String SrcLoc+  | ClosingTagMismatch String SrcLoc+  | JunkAtTheEnd Slice SrcLoc+  | UnexpectedEndOfStream+  | BadAttributeForm SrcLoc+  | BadTagForm SrcLoc+  | UnfinishedComment SrcLoc+  | Garbage SrcLoc+  | InvalidNullName SrcLoc+   deriving Show++#if __GLASGOW_HASKELL__ < 800+prettyCallStack = show+#endif++instance Exception Error++instance Show Error where+  show (Error etype cs) = show etype ++ prettyCallStack cs
+ src/Text/Xml/Tiny/Internal/Checks.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE ViewPatterns, NamedFieldPuns, CPP #-}+module Text.Xml.Tiny.Internal.Checks where++import Text.Printf++#ifdef ENABLE_CONSISTENCY_CHECKS+doStackChecks = True+doCursorChecks = True+doParseTableChecks = True+#else+doStackChecks = False+doCursorChecks = False+doParseTableChecks = False+#endif+{-# INLINE doStackChecks #-}+{-# INLINE doCursorChecks #-}+{-# INLINE doParseTableChecks #-}++-- checkCursor :: ParseMonad s ()+checkBSaccess o l o0 l0 =+      let valid n = let x = fromIntegral n in x >= o0 && x < o0+l0+          check = (valid o && valid (o+l))+              || error (printf "access to source out of bounds: o=%d, l=%d" o l)+      in check `seq` ()
+ src/Text/Xml/Tiny/Internal/Monad.hs view
@@ -0,0 +1,287 @@+{-# OPTIONS_GHC -fno-warn-name-shadowing -fobject-code #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-}+{-# LANGUAGE ViewPatterns, BangPatterns #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MagicHash  #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE DisambiguateRecordFields #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE CPP #-}++module Text.Xml.Tiny.Internal.Monad where+import qualified Control.Exception as CE+import Control.Monad+import Control.Monad.Primitive+import Control.Monad.ST+import Control.Monad.ST.Unsafe+import GHC.ST (ST(..))+import Control.Monad.State.Class+import Data.ByteString.Internal (ByteString(..), c2w, w2c, memchr, memcmp)+import qualified Data.ByteString.Char8 as BS+import Data.Int+import Data.Word+import Foreign.ForeignPtr+import Foreign.ForeignPtr.Unsafe+import Foreign.Storable hiding (peek)+import qualified Foreign.Storable as Foreign+import Foreign.Ptr+import GHC.Int++import Data.VectorBuilder.Storable (VectorBuilder)+import qualified Data.VectorBuilder.Storable as VectorBuilder+import Text.Xml.Tiny.Internal as Slice+import Text.Xml.Tiny.Internal.Checks++import Config+import qualified GHC.Stack+import Text.Printf++type MonadParse m = MonadState ParseState m++type ParseState = Slice++-- | The mutable environment of the ParseMonad.+data Env s =+  Env { source          :: !ByteString  -- ^ The input bytestring containing the XML document+      , ptr             :: {-# UNPACK #-} !(Ptr Word8) -- ^ A pointer to the raw bits of the above bytestring+      , attributeBuffer :: {-# UNPACK #-} !(VectorBuilder s AttributeParseDetails) -- ^ All the attributes parsed so far+      , nodeBuffer      :: {-# UNPACK #-} !(VectorBuilder s ParseDetails) -- ^ All the nodes parsed so far+      }++-- | A Reader Env, State Slice, ST monad,+--   the cursor Slice is deconstructed to its component in the STS monad.+newtype ParseMonad s a = PM {unPM :: Env s -> Slice -> ST s (a,Slice)}++liftST :: Config => ST s a -> ParseMonad s a+liftST action = PM $ \_ slice -> (,slice) <$> action++unsafeLiftIO :: Config => IO a -> ParseMonad s a+unsafeLiftIO action = liftST (unsafeIOToST action)++runPM :: Config => ByteString -> (forall s. ParseMonad s a) -> a+runPM bs@(PS fptr (fromIntegral -> o) (fromIntegral -> l)) pm = runST $ do+  -- initial buffer sizes copied from hexml+  attributes <- VectorBuilder.new 1000+  nodes <- VectorBuilder.new 500+  let ptr = unsafeForeignPtrToPtr fptr+  (res,_) <- unPM pm (Env bs ptr attributes nodes) (Slice o l)+  return res++-- | Render a BS slice in the source bytestring.+readStr :: Config => Slice -> ParseMonad s ByteString+readStr str = do+  Env{source = PS fptr _ _} <- getEnv+  return $! fromIndexPtr str fptr++{-# INLINE getBS #-}+-- | Get the rest of the document from the current cursor+getBS :: Config => ParseMonad s ByteString+getBS = get >>= readStr++unsafeIO :: Config => String -> IO a -> ParseMonad s a+unsafeIO msg action = unsafeLiftIO $ do+#ifdef TRACE_UNSAFE+  res <- trace ("About to start unsafe IO: " ++ msg) $ action+  trace ("Completed unsafe IO: " ++ msg) $ return res+#else+  action+#endif++{-# INLINE withCursor #-}+withCursor k = do+  checkCursor+  Env{ptr=p} <- getEnv+  Slice o l <- get+  k p o l++-- | Look ahead. Peek at the current cursor (CPS to avoid unnecesary allocations)+peek :: Config => (Char -> a) -> ParseMonad s a+peek = peekAt 0++-- | Arbitrary look-ahead (CPS)+peekAt :: Config => Int32 -> (Char -> a) -> ParseMonad s a+peekAt i pred = withCursor $ \p o l ->+  if (l < i) then throw UnexpectedEndOfStream else peekAtUnsafePO i pred p o++{-# INLINE peekAtUnsafePO #-}+peekAtUnsafePO i pred p o = (pred.w2c) <$> unsafeIO "BS" (peekByteOff p (fromIntegral $ i + o))++-- | Look-ahead a pair of positions, optimizing a common case (CPS)+bsIndex2 :: Config => Int32 -> Int32 -> (Char -> Char -> a) -> ParseMonad s a+bsIndex2 i j pred = withCursor $ \p o l ->+  if (l<i || l<j) then throw UnexpectedEndOfStream else do+    checkCursor+    byteI <- peekAtUnsafePO i id p o+    byteJ <- peekAtUnsafePO j id p o+    return $ pred byteI byteJ++-- | isPrefix at the current cursor+bsIsPrefix :: Config => ByteString -> ParseMonad s Bool+bsIsPrefix (PS r o' l') = withCursor $ \p o _ -> do+  resp <-+        unsafeIO "memcmp" $ withForeignPtr r $ \p' ->+          memcmp (p' `plusPtr` o') (p `plusPtr` fromIntegral o) (fromIntegral l')+  let res = resp == 0+  return res++-- | elem index from the current cursor+bsElemIndex :: Char -> ParseMonad s (Maybe Int)+bsElemIndex c = withCursor $ \p o l -> do+  let !p' = p `plusPtr` fromIntegral o+  !q <- unsafeIO "memchr" $ memchr p' (c2w c) (fromIntegral l)+  let !res = if q == nullPtr then Nothing else Just $! q `minusPtr` p'+  return res+{-# INLINE bsElemIndex #-}++-- | drop while from the current cursor+bsDropWhile :: (Char -> Bool) -> ParseMonad s ()+bsDropWhile f = withCursor $ \p o l -> do+  !n <- unsafeIO "BS" $ findIndexOrEnd (not.f.w2c) (p `plusPtr` fromIntegral o) l+  put $ Slice (o+n) (l-n)+{-# INLINE bsDropWhile #-}++-- | Move the cursor ahead while the predicate is true, and return the dropped slice.+{-# INLINE bsSpan #-}+bsSpan :: (Char -> Bool) -> ParseMonad s Slice+bsSpan f = withCursor $ \ p o l -> do+  !n <- unsafeIO "BS" $ findIndexOrEnd (not.f.w2c) (p `plusPtr` fromIntegral o) l+  put $ Slice (o+n) (l-n)+  return $! Slice o n++{-# INLINE findIndexOrEnd #-}+findIndexOrEnd k p l = go p 0 where+    go !ptr !n | n >= l    = return l+               | otherwise = do !w <- Foreign.peek ptr+                                if k w+                                  then return n+                                  else go (ptr `plusPtr` 1) (n+1)++-- | Return the current cursor location+{-# INLINE loc #-}+loc :: ParseMonad s SrcLoc+loc = get >>= \ (Slice o _) -> return $ SrcLoc $ fromIntegral o++throw :: HasCallStack => ErrorType -> a+#if __GLASGOW_HASKELL__ < 800+throw e = CE.throw $ Error e ?callStack+#else+throw e = CE.throw $ Error e GHC.Stack.callStack+#endif++-- | Throw with the current cursor location+throwLoc :: Config => (SrcLoc -> ErrorType) -> ParseMonad s a+throwLoc e = loc >>= throw . e++{-# INLINE getEnv #-}+getEnv :: ParseMonad s (Env s)+getEnv = PM $ \e s -> return (e,s)++-- | Push a node into the temporary stack+pushNode :: Config => ParseDetails -> ParseMonad s Int32+pushNode node = do+  Env{nodeBuffer} <- getEnv+  VectorBuilder.push nodeBuffer node+{-# INLINE pushNode #-}++{-# INLINE popNodes #-}+-- | Pop the topmost n elements from the node buffer stack+popNodes :: Config => Int32 -> ParseMonad s ()+popNodes n = do+  Env{nodeBuffer} <- getEnv+  VectorBuilder.pop nodeBuffer n++peekNode :: Config => Int32 -> ParseMonad s ParseDetails+peekNode n = do+  Env{nodeBuffer} <- getEnv+  VectorBuilder.peek nodeBuffer n+{-# INLINE peekNode #-}++-- | Insert a node into permanent storage+insertNode :: Config => ParseDetails -> ParseMonad s ()+insertNode node = do+  Env{nodeBuffer} <- getEnv+  VectorBuilder.insert nodeBuffer node+{-# INLINE insertNode #-}++insertAttribute :: AttributeParseDetails -> ParseMonad s ()+insertAttribute att = do+  Env{attributeBuffer} <- getEnv+  VectorBuilder.insert attributeBuffer att+{-# INLINE insertAttribute #-}++getNodeBufferCount, getAttributeBufferCount, getNodeStackCount :: Config => ParseMonad s Int32+getNodeBufferCount = do+  Env{nodeBuffer} <- getEnv+  VectorBuilder.getCount nodeBuffer+{-# INLINE getNodeBufferCount #-}++getAttributeBufferCount = do+  Env{attributeBuffer} <- getEnv+  VectorBuilder.getCount attributeBuffer+{-# INLINE getAttributeBufferCount #-}++getNodeStackCount = do+  Env{nodeBuffer} <- getEnv+  VectorBuilder.getStackCount nodeBuffer+{-# INLINE getNodeStackCount #-}++-- | Update a node in the stack buffer+{-# INLINE updateNode #-}+updateNode :: Int32 -> (ParseDetails -> ParseDetails) -> ParseMonad s ()+updateNode i f = do+  Env{nodeBuffer} <- getEnv+  VectorBuilder.updateStackElt nodeBuffer i f++instance Functor (ParseMonad s) where+  fmap = liftM++instance Applicative (ParseMonad s) where+  pure x = PM (\_ s -> return (x,s))+  (<*>) = ap++instance Monad (ParseMonad s) where+  {-# INLINE (>>=) #-}+  PM m >>= k = PM (\e s -> m e s >>= \(a,s') -> unPM (k a) e s')++instance MonadState ParseState (ParseMonad s) where+  get = PM $ \_ s -> return (s,s)+  put s = PM $ \_ _ -> return ((), s)++instance PrimMonad (ParseMonad s) where+  type PrimState(ParseMonad s) = s+  {-# INLINE primitive #-}+  primitive act = PM (\_ s -> (,s) <$> ST act )++checkCursor+  | doCursorChecks = do+      Env{source = PS _ o0 l0} <- getEnv+      Slice o l <- get+      return $ checkBSaccess o l o0 l0+  | otherwise = return ()++checkConsistency (fromIntegral -> outerStart) (fromIntegral -> innerClose) origStr seenStr+  | doStackChecks = do+            nameBS_original <- readStr origStr+            seenBS <- readStr seenStr+            unless (seenBS == nameBS_original) $ do+                xml <- readStr(Slice outerStart (min 100 $ innerClose + fromIntegral( Slice.length origStr) + 4 - outerStart))+                total <- getNodeStackCount+                let go n+                     | n >= total = return []+                     | otherwise = do+                          node <- peekNode n+                          nBS <- readStr (name node)+                          (BS.unpack nBS :) <$> go (n+1)+                stackNames <- go 0+                error $ printf "Inconsistency detected in the node stack while parsing %s...\n Expected %s(%s), but obtained %s(%s) (and the stack contains %s)"+                                (BS.unpack xml) (BS.unpack nameBS_original) (show origStr) (BS.unpack seenBS) (show seenStr)(show stackNames)+  | otherwise =+      return ()++{-# INLINE checkConsistency #-}+{-# INLINE checkCursor #-}
+ src/Text/Xml/Tiny/Internal/Parser.hs view
@@ -0,0 +1,277 @@+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# LANGUAGE DisambiguateRecordFields #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE NamedFieldPuns #-}++-- | A hand rolled predictive recursive descent parser for a subset of XML.+--   There is no lexer, the parser assumes Char8 tokens.+--   The parser state is held in the Environment data structure of a ParseMonad+module Text.Xml.Tiny.Internal.Parser (parse) where++import Control.Exception (try, evaluate, assert)+import Control.Monad+import Control.Monad.State.Class+import qualified Data.ByteString.Char8 as BS+import Data.ByteString.Internal (ByteString(..))+import Data.Char hiding (Space)+import qualified Data.VectorBuilder.Storable as VectorBuilder+import qualified Data.Vector.Unboxed as U+import System.IO.Unsafe+import Text.Printf++import Text.Xml.Tiny.Internal.Monad+import Text.Xml.Tiny.Internal as Slice+import Config++default (Int, Double)++{-# INLINE skip #-}+skip :: (Integral a, Config) => a -> ParseMonad s ()+skip = modify . Slice.drop++{-# INLINE pop #-}+pop :: Config => (Char -> a) -> ParseMonad s a+pop pred = peek pred <* skip 1++{-# INLINE findAndPop #-}+findAndPop :: Config => Char -> (SrcLoc -> ErrorType) -> (Slice -> ParseMonad s r) -> ParseMonad s r+findAndPop !c mkE k = do+  !x <- bsElemIndex c+  case x of+    Nothing ->+      throwLoc mkE+    Just !i -> do+      cursor <- get+      let !prefix = Slice.take i cursor+      put(Slice.drop (i+1) cursor)+      k prefix++{-# INLINE trim #-}+trim :: Config => ParseMonad s ()+trim =+  bsDropWhile isSpace+    where+      isSpace !c = spaceTable `indexU` ord c++{-# INLINE expectLoc #-}+expectLoc :: Config => (Char -> Bool) -> _ -> ParseMonad s ()+expectLoc pred e = do+  !b <- peek pred+  unless b $ do+    c <- pop id+    throwLoc(e c)+  skip 1++{-# INLINE parseName #-}+parseName :: Config => ParseMonad s Slice+parseName = do+  !first <- peek isName1+  case first of+    False -> return Slice.empty+    True  -> do+      slice@(Slice _ l) <- bsSpan isName+      assert (l > 0 || error(show slice)) $ return slice+ where+    isName1 c = nameTable1 `indexU` ord c+    isName  c = nameTable  `indexU` ord c++-- | Assumes cursor is on a '='+{-# INLINE parseAttrVal #-}+parseAttrVal :: Config => Slice -> ParseMonad s ()+parseAttrVal n = do+  trim+  expectLoc (== '=') (const BadAttributeForm)+  trim+  !c  <- pop id+  unless (c == '\'' || c == '\"') (throwLoc BadAttributeForm)+  findAndPop c BadAttributeForm (insertAttribute . AttributeParseDetails n)++{-# INLINE parseAttr #-}+parseAttr :: Config => ParseMonad s Bool+parseAttr = do+    trim+    !n <- parseName+    if Slice.null n+      then return False+      else do+        parseAttrVal n+        return True++parseAttrs :: Config => ParseMonad s Slice+parseAttrs = do+  !initial <- getAttributeBufferCount+  let goParseAttrs = do+        !success <- parseAttr+        when success goParseAttrs+  goParseAttrs+  !current <- getAttributeBufferCount+  return (Slice (fromIntegral initial) (fromIntegral $ current-initial))+{-# INLINE parseAttrs #-}++{-# INLINE parseNode #-}+parseNode :: Config => ParseMonad s ()+parseNode = do+    SrcLoc outerOpen <- loc+    expectLoc (== '<') $ \c -> error( "parseNode: expected < got " ++ [c] )+    !c <- peek (== '?')+    when c (skip 1)+    !name <- parseName+    when (Slice.null name) $ throwLoc InvalidNullName+    do+        !attrs <- parseAttrs+        (isTagEnd, isTagClose) <- bsIndex2 0 1 $ \c n -> ((c == '/' || c == '?') && n == '>', c == '>')+        skip 1+        if isTagEnd+          -- this is a tag with no children+          then do+            skip 1+            SrcLoc outerClose <- loc+            let !outer = fromOpenClose outerOpen outerClose+            let inner = Slice.empty+            _ <- pushNode(ParseDetails name inner outer attrs Slice.empty)+            return ()+          else do+            unless isTagClose $ do+              nameBS <- readStr name+              throwLoc (UnterminatedTag$ BS.unpack nameBS)+            SrcLoc innerOpen <- loc+            -- record a partial entry to insert at the right point in the stack+            -- and to (hopefully) allow the GC to release all the node details already+            me <- pushNode(ProtoParseDetails name attrs (fromIntegral innerOpen) (fromIntegral outerOpen))+            !nn <- parseContents+            SrcLoc innerClose <- loc+            isTagEnd <- bsIndex2 0 1 $ \c n -> c == '<' && n == '/'+            skip 2+            !nameBS <- readStr name+            unless isTagEnd $ throwLoc (UnterminatedTag $ BS.unpack nameBS)+            !matchTag <- bsIsPrefix nameBS+            unless matchTag $+              throwLoc (ClosingTagMismatch $ BS.unpack nameBS)+            skip $! Slice.length name+            !bracket <- bsElemIndex '>'+            case bracket of+              Just i  -> skip $! (i+1)+              Nothing -> throwLoc BadTagForm+            SrcLoc outerClose <- loc+            -- Update the stack entry with the full details now+            updateNode me $ \n@ProtoParseDetails{name=name', innerStart = innerOpen', outerStart = outerOpen', attributes=attrs'} ->+              assert (name==name') $+              assert (innerOpen == fromIntegral innerOpen' || error (printf "Expected:%d, Obtained:%d, me: %d, node: %s" innerOpen innerOpen' me (show n))) $+              assert (outerOpen == fromIntegral outerOpen' || error (printf "Expected:%d, Obtained:%d" outerOpen outerOpen')) $+              ParseDetails name' (fromOpenClose innerOpen' innerClose) (fromOpenClose outerOpen' outerClose) attrs' nn++commentEnd :: ParseMonad s ()+{-# INLINE commentEnd #-}+commentEnd  = do+  !end <- bsElemIndex '>'+  case end of+    Nothing -> throwLoc UnfinishedComment+    Just !end -> do+      skip $! (end+1)+      isEnd <- bsIndex2 (-2) (-3) $ \p p' -> p == '-' && p' == '-'+      unless isEnd commentEnd++{-# INLINE dropComments #-}+dropComments :: ParseMonad s Bool+dropComments = do+  !x <- bsIsPrefix "<!--"+  when x $ do+    skip 4+    commentEnd+  return x++-- | Parses a sequence of zero or more nodes.+parseContents :: forall s. Config => ParseMonad s Slice+parseContents = do+  -- Record how many elements are there in the node stack before parsing the contents+  !before <- getNodeStackCount++  -- the recursive worker+  let goParseContents :: Config => ParseMonad s ()+      goParseContents = do+        -- we can skip all characters until we find a start tag+        -- this is key to good performance+        !start <- bsElemIndex '<'+        case start of+          Just i -> do+            skip i+            -- if look ahead reveals the "</" sequence then this is an end tag and we're done+            !end <- peekAt 1 (== '/')+            unless end $ do+                -- is this a real tag or a user comment ?+                !wasComment <- dropComments+                if wasComment+                  then+                    -- after wiping out comments, start over+                    goParseContents+                  else do+                    -- looks like we've found a node, parse it and start over+                    _ <- parseNode+                    goParseContents+          -- no tag+          _ ->+            return ()+  -- loop until we run out of tag openers+  () <- goParseContents+  -- and find out how much the stack has grown+  !after <- getNodeStackCount+  !front <- getNodeBufferCount+  -- The new unpopped items in the stack are the ones parsed by us+  -- Pop them out an return a slice identifying them.+  let diff = after - before+  popNodes diff+  return $! Slice front diff++type ParseTable = U.Vector Bool++-- TODO compute at compile time?+spaceTable,nameTable,nameTable1 :: ParseTable+spaceTable = U.generate 256 (isSpace . chr)++nameTable = U.generate 256 $ \i ->+   case chr i of+      ':' -> True+      '_' -> True+      c | isLetter c -> True+      '-' -> True+      c | isDigit c -> True+      _   -> False++nameTable1 = U.generate 256 $ \i ->+   case chr i of+      ':' -> True+      '_' -> True+      c | isLetter c -> True+      _   -> False++#ifdef ENABLE_VECTOR_CHECKS+indexU = (U.!)+#else+indexU = U.unsafeIndex+#endif++parse :: Config => ByteString -> Either Error _+parse bs = unsafePerformIO $ do+  res <- try $ evaluate $ runPM bs $ do+    it <- parseContents+    Env{attributeBuffer, nodeBuffer} <- getEnv+    attributesV <- VectorBuilder.finalize attributeBuffer+    nodesV <- VectorBuilder.finalize nodeBuffer+    return (it, attributesV, nodesV)+  let len = fromIntegral $ BS.length bs+  return $! case res of+    Right (!it, attributesV, nodesV) ->+      let rootNode = ParseDetails Slice.empty (Slice 0 len) (Slice 0 len) Slice.empty it+      in Right (attributesV, nodesV, rootNode )+    Left e ->+      Left e
+ tinyXml.cabal view
@@ -0,0 +1,82 @@+name:                tinyXml ++-- The package version.  See the Haskell package versioning policy (PVP) +-- for standards guiding when and how versions should be incremented.+-- https://wiki.haskell.org/Package_versioning_policy+-- PVP summary:      +-+------- breaking API changes+--                   | | +----- non-breaking API additions+--                   | | | +--- code changes with no API change+version:             0.1.0.0++synopsis:            A fast DOM parser for a subset of XML++description:         Fast DOM parser for XML with no support for entities, CDATA sections nor namespaces.++license:             BSD3++license-file:        LICENSE++author:              Pepe Iborra++maintainer:          pepeiborra@gmail.com++category:            XML++build-type:          Simple++extra-source-files:  ChangeLog.md, xml/benchmark.xml.bz2, xml/mail.xml.bz2+extra-tmp-files:     xml/benchmark.xml, xml/mail.xml, xml/benchmark.xml.reprint, xml/mail.xml.reprint++cabal-version:       >=1.22++tested-with:         GHC == 7.10.3, GHC == 8.0.1++source-repository head+  type: git+  location: https://github.com/pepeiborra/tinyXml++Flag Debug+    Description:     enables call stacks and other debug options+    Default: False++library+  hs-source-dirs:      src+  exposed-modules:     Text.Xml.Tiny,+                       Text.Xml.Tiny.Internal+  other-modules:       Config,+                       Data.VectorBuilder.Storable,+                       Text.Xml.Tiny.Internal.Parser,+                       Text.Xml.Tiny.Internal.Checks,+                       Text.Xml.Tiny.Internal.Monad++  if impl(ghc < 8)+            default-extensions: FlexibleContexts+  other-extensions:    OverloadedStrings, BangPatterns, DisambiguateRecordFields, FlexibleContexts, TemplateHaskell, ConstraintKinds, NoMonomorphismRestriction, LambdaCase, OverloadedLists, PartialTypeSignatures+  build-depends:       base >=4.8 && <5, bytestring >=0.10 && <0.11, mtl >=2.2 && <2.3, containers >=0.5 && <0.6, vector >= 0.11, primitive+  default-language:    Haskell2010+  if impl(ghc >= 8)+    default-extensions:  StrictData+  ghc-options:         -funfolding-use-threshold=10000+  ghc-options:         -fno-warn-partial-type-signatures+  if flag(Debug)+     cpp-options:         -DDEBUG -DSTACKTRACES++test-suite test+        type: exitcode-stdio-1.0+        main-is: Test.hs+        -- we want to rebuild with asserts on+        hs-source-dirs:      .,src+        default-language:    Haskell2010+        build-depends: base, bytestring, tinyXml, mtl, containers, vector >= 0.11, hexml, filepath, primitive, process+        default-language:    Haskell2010+        ghc-options:         -fno-warn-partial-type-signatures -fno-ignore-asserts -O0+        cpp-options:         -DENABLE_CONSISTENCY_CHECKS -DENABLE_VECTOR_CHECKS -DDEBUG -DSTACKTRACES+        if impl(ghc < 8)+            default-extensions: FlexibleContexts++Executable validate +        main-is: Validate.hs+        build-depends:  base, bytestring, tinyXml, mtl, optparse-generic, directory, filepath+        ghc-options: -rtsopts+        default-language:    Haskell2010+        ghc-options:         -fno-warn-partial-type-signatures -rtsopts
+ xml/benchmark.xml.bz2 view

file too large to diff

+ xml/mail.xml.bz2 view

binary file changed (absent → 317 bytes)